- AGNDXP ; IHS/ASDS/EFG - PRINT AN INDEX CARD-DFN REQUIRED ;
- ;;7.1;PATIENT REGISTRATION;**4,11**;AUG 25,2005;Build 1
- ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
- ;
- S AGLN=0
- G END:'$D(DFN),END:'$D(^DPT(DFN,0)),END:'$D(^AUPNPAT(DFN,41,DUZ(2),0))
- D NMCH F AG("I")=1:1:17-AGLN W !
- I '$D(AGALIAS) G END
- S (AGLN,AG("ALNO"))=0
- ALIASLP S AG("ALNO")=AG("ALNO")+1 G END:'$D(^DPT(DFN,.01,AG("ALNO"),0)),ALIASLP:$P(^DPT(DFN,.01,AG("ALNO"),0),U)=""
- W $P(^DPT(DFN,.01,AG("ALNO"),0),U),"**ALIAS**",! S AGLN=AGLN+1
- D NMCH F AG("I")=1:1:17-AGLN W !
- S AGLN=0
- G ALIASLP
- NMCH S AGDPT=^DPT(DFN,0),AG41=^AUPNPAT(DFN,41,DUZ(2),0)
- W $P(AGDPT,U),?45-$L($P(AG41,U,2)),$P(AG41,U,2) D LINE ;Line 1
- S AGDOB="",Y=$P(AGDPT,U,3) I +Y D DD^%DT S AGDOB=Y
- ;IHS/OIT/NKD AG*7.1*11 MU2 - DISPLAY OF SEX TO INCLUDE UNKNOWN
- ;S A=$P(AGDPT,U,2),AGSEX=$S(A="M":"MALE",A="F":"FEMALE",1:" ")
- S AGSEX=$$GET1^DIQ(2,DFN,.02),AGSEX=$S(AGSEX]"":AGSEX,1:" ")
- ;S A=$P(AGDPT,U,9) S:$L(A)=9 A=$E(A,1,3)_"-"_$E(A,4,5)_"-"_$E(A,6,99) S AGSSN=A
- S AGSSN=$$GET1^DIQ(9000001,DFN_",",1107.3) ;IHS/SD/TPF AG*7.1*4
- W AGDOB,?45-$L(AGSEX)\2,AGSEX,?45-$L(AGSSN),AGSSN D LINE ;Line 2
- S (AGSTREET,AGADDR)="" I $D(^DPT(DFN,.11)) S A=^(.11),AGSTREET=$P(A,U) S:$P(A,U,4)]"" AGADDR=AGADDR_$P(A,U,4) I +$P(A,U,5),$D(^DIC(5,+$P(A,U,5),0)) S AGADDR=AGADDR_" "_$P(^(0),U,2)_" "_$P(A,U,6)
- W AGSTREET I $D(^DPT(DFN,.13)),$P(^(.13),U)]"" S X="HOME PH: "_$P(^(.13),U) W ?45-$L(X),X ; Line 3
- W !,AGADDR I $D(^DPT(DFN,.13)),$P(^(.13),U,2)]"" S X="OFFICE PH: "_$P(^(.13),U,2) W ?45-$L(X),X ; Line 4
- D LINE
- I $D(^DPT(DFN,.24)) W " FATHER: ",$P(^(.24),U),!,"MOTHER (MDN): ",$P(^(.24),U,3) S AGLN=AGLN+1 D LINE
- S Y=DT D DD^%DT W "CARD PRINTED: ",Y G NMCHEND:$P(AG41,U,3)=""
- I $P(AG41,U,3),+$P(AG41,U,4),$D(^AUTTDIS($P(AG41,U,4),0)) W !,"CHART ",$S($P(^(0),U)["ARCH":"ARCHIVED: ",1:"INACTIVATED: ") S Y=$P(AG41,U,3) D DD^%DT W Y S AGLN=AGLN+1
- NMCHEND Q
- END K A,AGADDR,AG41,AGDOB,AGDPT,AGSEX,AGSSN,AGSTREET,AGLN,X
- Q
- LINE W ! F AG("I")=1:1:45 W "-"
- W !
- S AGLN=AGLN+2
- Q
- ALIAS ;EP
- W !!!,"Do you want to print index cards for ALIASES also? (Y/N) Y// " D READ^AG S Y=$E(Y_"Y") I $D(DQOUT) W !!,"An index card will be printed for the patients NAME and each ALIAS",!,"if you answer ""Y"" " G ALIAS
- Q:$D(DTOUT)!$D(DFOUT)!$D(DUOUT) I "NY"'[Y D YN^AG G ALIAS
- K AGALIAS I Y="Y" S AGALIAS=""
- TEST W !!!,"DO YOU WANT TO PRINT A TEST LABEL? (Y/N) N// " D READ^AG S Y=$E(Y_"N") I $D(DQOUT) W !!,"A sample label will be printed so that you",!,"may allign your labels on the printer." G TEST
- Q:(Y="N")!$D(DTOUT)!$D(DFOUT)!$D(DUOUT) I Y'="Y" D YN^AG G TEST
- D ^%ZIS Q:POP U IO F I=1:1:3 W "TESTTESTTESTTESTTESTTESTTESTTESTTESTTESTTESTTESTXX",!
- W !!!!!!!!!!!!!!! D ^%ZISC
- G TEST
- AGNDXP ; IHS/ASDS/EFG - PRINT AN INDEX CARD-DFN REQUIRED ;
- +1 ;;7.1;PATIENT REGISTRATION;**4,11**;AUG 25,2005;Build 1
- +2 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
- +3 ;
- +4 SET AGLN=0
- +5 IF '$DATA(DFN)
- GOTO END
- IF '$DATA(^DPT(DFN,0))
- GOTO END
- IF '$DATA(^AUPNPAT(DFN,41,DUZ(2),0))
- GOTO END
- +6 DO NMCH
- FOR AG("I")=1:1:17-AGLN
- WRITE !
- +7 IF '$DATA(AGALIAS)
- GOTO END
- +8 SET (AGLN,AG("ALNO"))=0
- ALIASLP SET AG("ALNO")=AG("ALNO")+1
- IF '$DATA(^DPT(DFN,.01,AG("ALNO"),0))
- GOTO END
- IF $PIECE(^DPT(DFN,.01,AG("ALNO"),0),U)=""
- GOTO ALIASLP
- +1 WRITE $PIECE(^DPT(DFN,.01,AG("ALNO"),0),U),"**ALIAS**",!
- SET AGLN=AGLN+1
- +2 DO NMCH
- FOR AG("I")=1:1:17-AGLN
- WRITE !
- +3 SET AGLN=0
- +4 GOTO ALIASLP
- NMCH SET AGDPT=^DPT(DFN,0)
- SET AG41=^AUPNPAT(DFN,41,DUZ(2),0)
- +1 ;Line 1
- WRITE $PIECE(AGDPT,U),?45-$LENGTH($PIECE(AG41,U,2)),$PIECE(AG41,U,2)
- DO LINE
- +2 SET AGDOB=""
- SET Y=$PIECE(AGDPT,U,3)
- IF +Y
- DO DD^%DT
- SET AGDOB=Y
- +3 ;IHS/OIT/NKD AG*7.1*11 MU2 - DISPLAY OF SEX TO INCLUDE UNKNOWN
- +4 ;S A=$P(AGDPT,U,2),AGSEX=$S(A="M":"MALE",A="F":"FEMALE",1:" ")
- +5 SET AGSEX=$$GET1^DIQ(2,DFN,.02)
- SET AGSEX=$SELECT(AGSEX]"":AGSEX,1:" ")
- +6 ;S A=$P(AGDPT,U,9) S:$L(A)=9 A=$E(A,1,3)_"-"_$E(A,4,5)_"-"_$E(A,6,99) S AGSSN=A
- +7 ;IHS/SD/TPF AG*7.1*4
- SET AGSSN=$$GET1^DIQ(9000001,DFN_",",1107.3)
- +8 ;Line 2
- WRITE AGDOB,?45-$LENGTH(AGSEX)\2,AGSEX,?45-$LENGTH(AGSSN),AGSSN
- DO LINE
- +9 SET (AGSTREET,AGADDR)=""
- IF $DATA(^DPT(DFN,.11))
- SET A=^(.11)
- SET AGSTREET=$PIECE(A,U)
- IF $PIECE(A,U,4)]""
- SET AGADDR=AGADDR_$PIECE(A,U,4)
- IF +$PIECE(A,U,5)
- IF $DATA(^DIC(5,+$PIECE(A,U,5),0))
- SET AGADDR=AGADDR_" "_$PIECE(^(0),U,2)_" "_$PIECE(A,U,6)
- +10 ; Line 3
- WRITE AGSTREET
- IF $DATA(^DPT(DFN,.13))
- IF $PIECE(^(.13),U)]""
- SET X="HOME PH: "_$PIECE(^(.13),U)
- WRITE ?45-$LENGTH(X),X
- +11 ; Line 4
- WRITE !,AGADDR
- IF $DATA(^DPT(DFN,.13))
- IF $PIECE(^(.13),U,2)]""
- SET X="OFFICE PH: "_$PIECE(^(.13),U,2)
- WRITE ?45-$LENGTH(X),X
- +12 DO LINE
- +13 IF $DATA(^DPT(DFN,.24))
- WRITE " FATHER: ",$PIECE(^(.24),U),!,"MOTHER (MDN): ",$PIECE(^(.24),U,3)
- SET AGLN=AGLN+1
- DO LINE
- +14 SET Y=DT
- DO DD^%DT
- WRITE "CARD PRINTED: ",Y
- IF $PIECE(AG41,U,3)=""
- GOTO NMCHEND
- +15 IF $PIECE(AG41,U,3)
- IF +$PIECE(AG41,U,4)
- IF $DATA(^AUTTDIS($PIECE(AG41,U,4),0))
- WRITE !,"CHART ",$SELECT($PIECE(^(0),U)["ARCH":"ARCHIVED: ",1:"INACTIVATED: ")
- SET Y=$PIECE(AG41,U,3)
- DO DD^%DT
- WRITE Y
- SET AGLN=AGLN+1
- NMCHEND QUIT
- END KILL A,AGADDR,AG41,AGDOB,AGDPT,AGSEX,AGSSN,AGSTREET,AGLN,X
- +1 QUIT
- LINE WRITE !
- FOR AG("I")=1:1:45
- WRITE "-"
- +1 WRITE !
- +2 SET AGLN=AGLN+2
- +3 QUIT
- ALIAS ;EP
- +1 WRITE !!!,"Do you want to print index cards for ALIASES also? (Y/N) Y// "
- DO READ^AG
- SET Y=$EXTRACT(Y_"Y")
- IF $DATA(DQOUT)
- WRITE !!,"An index card will be printed for the patients NAME and each ALIAS",!,"if you answer ""Y"" "
- GOTO ALIAS
- +2 IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DUOUT)
- QUIT
- IF "NY"'[Y
- DO YN^AG
- GOTO ALIAS
- +3 KILL AGALIAS
- IF Y="Y"
- SET AGALIAS=""
- TEST WRITE !!!,"DO YOU WANT TO PRINT A TEST LABEL? (Y/N) N// "
- DO READ^AG
- SET Y=$EXTRACT(Y_"N")
- IF $DATA(DQOUT)
- WRITE !!,"A sample label will be printed so that you",!,"may allign your labels on the printer."
- GOTO TEST
- +1 IF (Y="N")!$DATA(DTOUT)!$DATA(DFOUT)!$DATA(DUOUT)
- QUIT
- IF Y'="Y"
- DO YN^AG
- GOTO TEST
- +2 DO ^%ZIS
- IF POP
- QUIT
- USE IO
- FOR I=1:1:3
- WRITE "TESTTESTTESTTESTTESTTESTTESTTESTTESTTESTTESTTESTXX",!
- +3 WRITE !!!!!!!!!!!!!!!
- DO ^%ZISC
- +4 GOTO TEST
