AUPNLK2B ; IHS/CMI/LAB - Broke up AUPNLK2 because of size ;
;;99.1;IHS DICTIONARIES (PATIENT);**12**;MAR 09, 1999;Build 9
;
TALK ; TALK TO OPERATOR
D ASK ; Ask if want to add patient
Q:AUPQF2
D MIDDLE ; Ask for complete middle
D NICKNM ; Check for nicknames
D CHKID ; Get identifiers
Q:AUPQF2
D DUPECHK ; Check for dupes
Q:AUPQF2
W !!?3,"...adding new patient"
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
ASK ; ASK OPERATOR
F AUPL=0:0 D ASKADD Q:%
S:%'=1 AUPQF2=3
Q
;
ASKADD ;
S Y=+$P(^DPT(0),U,4)+1 W !?3,*7,"ARE YOU ADDING ",$S(AUPX'?.N:"'"_AUPX_"' AS ",1:""),"A NEW PATIENT (THE ",Y,$S(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),")"
S %=2 D YN^DICN I '% W !?6,"Enter 'YES' to add a new patient, or 'NO' not to."
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
MIDDLE ;
S AUPNMM=$P($P(AUPX,",",2)," ",2)
Q:$L(AUPNMM)>2
I $L(AUPNMM)=2,$E(AUPNMM,2)'="." Q
; IHS/SD/EFG AUPN*99.1*12 12/2/2003 FIX PROBLEM WITH MIDDLE
; OR NAME NOT POPULATING PATIENT FILES CORRECTLY
;W !!?3,"Enter complete middle name if known,",!?5," or press <return> to add as entered: " R X:DTIME
;I '$T!(X="^") Q
;S Y=AUPX,Z=$P(Y,",",2),$P(Z," ",2)=X,$P(Y,",",2)=Z,X=Y K Z
;D NAME^AUPNPED
;Q:'$D(X)
;S AUPX=X
K DIR
S DIR(0)="FO^2:15"
S DIR("A")="Enter complete middle name if known or press <return> to add as entered: "
D ^DIR
S:Y="/.,"!(Y="^^") DFOUT=""
Q:$D(DFOUT)!$D(DUOUT)!$D(DTOUT)
I $G(X)'="" S Y=AUPX,Z=$P(Y,",",2),$P(Z," ",2)=X,$P(Y,",",2)=Z,X=Y K Z
I $G(X)="" S X=AUPX
D NAME^AUPNPED
K DIR,DFOUT,DUOUT,X,Y
; END OF CODE CHANGES FOR AUPN*99.1*12
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
NICKNM ; CHECK FIRST & MIDDLE NAMES FOR NICK NAMES
S AUPNML=$P(AUPX,",",1),AUPNMF=$P($P(AUPX,",",2)," ",1),AUPNMM=$P($P(AUPX,",",2)," ",2),AUPNMX=$P(AUPX,",",3)
I AUPNMF'="",$D(^APMM(99,"B",AUPNMF)) S AUPNMCVN=1 F AUPNMCV=0:0 S AUPNMCV=$O(^APMM(99,"B",AUPNMF,AUPNMCV)) Q:AUPNMCV="" D NICKNM2 Q:AUPNMCV=""
I AUPNMM'="",$D(^APMM(99,"B",AUPNMM)) S AUPNMCVN=2 F AUPNMCV=0:0 S AUPNMCV=$O(^APMM(99,"B",AUPNMM,AUPNMCV)) Q:AUPNMCV="" D NICKNM2 Q:AUPNMCV=""
S AUPX=AUPNML_","_AUPNMF_$S(AUPNMM'="":" "_AUPNMM,1:"")_$S(AUPNMX'="":","_AUPNMX,1:"")
K AUPNML,AUPNMF,AUPNMM,AUPNMCV,AUPNMCVN,AUPNMCVX,AUPNMX
Q
;
NICKNM2 ; CHECK NICK NAMES
S AUPNMCVX=$S(AUPNMCVN=1:AUPNMF,1:AUPNMM)
Q:AUPNMCVX=$P(^APMM(99,AUPNMCV,0),U,1)
W !," Do you want ",$S(AUPNMCVN=1:AUPNMF,1:AUPNMM)," entered as ",$P(^APMM(99,AUPNMCV,0),U,1)
S %=2 D YN^DICN
S:%=1 @($S(AUPNMCVN=1:"AUPNMF",1:"AUPNMM"))=$P(^APMM(99,AUPNMCV,0),U,1),AUPNMCV=""
K %,%Y
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
CHKID ; CHECK IDENTIFIERS
Q:$D(DIC("DR"))
S AUPGID="^.02^.03^.09^"
F AUPID=.02,.03,.09 D CHKID1 Q:AUPQF2
Q:AUPQF2
F AUPID=0:0 S AUPID=$O(^DD(2,0,"ID",AUPID)) Q:'AUPID!(AUPQF2) I '$F(AUPGID,U_AUPID_U) S AUPLID="",AUP("DR")=AUP("DR")_";"_AUPID
Q
;
CHKID1 ;
S AUP("DR")=$S('$D(AUP("DR")):AUPID,1:AUP("DR")_";"_AUPID) I $D(^DD(2,AUPID,0)) S AUPID0=^(0) D ASKID S:'$D(X) AUPQF2=4
Q
;
ASKID W !?3,"PATIENT ",$P(AUPID0,U),": " R X:DTIME I '$T!(X?1"^") W !?6,*7,"<'",AUPX,"'> DELETED" K X Q
I X="",AUPID=.09 S AUPIDS(AUPID)="",AUP("DR")=AUP("DR")_"////"_X Q
I X["^" W:$E(X)["^" !?6,*7,"Sorry, '^' not allowed!" W " ??" G ASKID
I X["?"!(X="") W:X="" *7," ??" D HLPID G ASKID
I $P(AUPID0,U,2)["S" F I=1:1 S Y=$P($P(AUPID0,U,3),";",I) K:Y="" X Q:Y="" I $P(Y,":",1)=X!($E($P(Y,":",2),1,$L(X))=X) S X=$P(Y,":",1),AUPSET=$P(Y,":",2) Q
S (DA,D0)=0
X $P(^DD(2,AUPID,0),U,5,99) I $D(X) W:$D(AUPSET) " ",AUPSET S AUPIDS(AUPID)=X,AUP("DR")=AUP("DR")_"////"_X K AUPSET Q
W:'$D(X)&($P(AUPID0,U,2)'["D") *7," ??" D HLPID
G ASKID
;
HLPID W:$D(^DD(2,AUPID,.1)) !?5,^(.1) W:$D(^DD(2,AUPID,3)) !?5,^(3) I $D(X),X["?" F I=0:0 S I=$O(^DD(2,AUPID,21,I)) Q:'I!(I>3&(X?1"?")) I $D(^(I,0)) W !?5,^(0) I I>2,X?1"?" W !?5,"..."
W:$D(^DD(2,AUPID,4)) !?5,^(4) I $P(AUPID0,U,2)["D" S X="?",%DT="E" D ^%DT
I $P(AUPID0,U,2)["S" W !?7,"CHOOSE FROM: " F I=1:1 S Y=$P($P(AUPID0,U,3),";",I) Q:Y="" W !?7,$P(Y,":",1),?15," ",$P(Y,":",2)
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
DUPECHK ; CHECK FOR DUPLICATE PATIENTS
Q:$D(DIC("DR"))
D ^AUPNLK3 S:AUPNLK3<0 AUPQF2=5 K AUPNLK3
Q
AUPNLK2B ; IHS/CMI/LAB - Broke up AUPNLK2 because of size ;
+1 ;;99.1;IHS DICTIONARIES (PATIENT);**12**;MAR 09, 1999;Build 9
+2 ;
TALK ; TALK TO OPERATOR
+1 ; Ask if want to add patient
DO ASK
+2 IF AUPQF2
QUIT
+3 ; Ask for complete middle
DO MIDDLE
+4 ; Check for nicknames
DO NICKNM
+5 ; Get identifiers
DO CHKID
+6 IF AUPQF2
QUIT
+7 ; Check for dupes
DO DUPECHK
+8 IF AUPQF2
QUIT
+9 WRITE !!?3,"...adding new patient"
+10 QUIT
+11 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+12 ;
ASK ; ASK OPERATOR
+1 FOR AUPL=0:0
DO ASKADD
IF %
QUIT
+2 IF %'=1
SET AUPQF2=3
+3 QUIT
+4 ;
ASKADD ;
+1 SET Y=+$PIECE(^DPT(0),U,4)+1
WRITE !?3,*7,"ARE YOU ADDING ",$SELECT(AUPX'?.N:"'"_AUPX_"' AS ",1:""),"A NEW PATIENT (THE ",Y,$SELECT(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),")"
+2 SET %=2
DO YN^DICN
IF '%
WRITE !?6,"Enter 'YES' to add a new patient, or 'NO' not to."
+3 QUIT
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
MIDDLE ;
+1 SET AUPNMM=$PIECE($PIECE(AUPX,",",2)," ",2)
+2 IF $LENGTH(AUPNMM)>2
QUIT
+3 IF $LENGTH(AUPNMM)=2
IF $EXTRACT(AUPNMM,2)'="."
QUIT
+4 ; IHS/SD/EFG AUPN*99.1*12 12/2/2003 FIX PROBLEM WITH MIDDLE
+5 ; OR NAME NOT POPULATING PATIENT FILES CORRECTLY
+6 ;W !!?3,"Enter complete middle name if known,",!?5," or press <return> to add as entered: " R X:DTIME
+7 ;I '$T!(X="^") Q
+8 ;S Y=AUPX,Z=$P(Y,",",2),$P(Z," ",2)=X,$P(Y,",",2)=Z,X=Y K Z
+9 ;D NAME^AUPNPED
+10 ;Q:'$D(X)
+11 ;S AUPX=X
+12 KILL DIR
+13 SET DIR(0)="FO^2:15"
+14 SET DIR("A")="Enter complete middle name if known or press <return> to add as entered: "
+15 DO ^DIR
+16 IF Y="/.,"!(Y="^^")
SET DFOUT=""
+17 IF $DATA(DFOUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+18 IF $GET(X)'=""
SET Y=AUPX
SET Z=$PIECE(Y,",",2)
SET $PIECE(Z," ",2)=X
SET $PIECE(Y,",",2)=Z
SET X=Y
KILL Z
+19 IF $GET(X)=""
SET X=AUPX
+20 DO NAME^AUPNPED
+21 KILL DIR,DFOUT,DUOUT,X,Y
+22 ; END OF CODE CHANGES FOR AUPN*99.1*12
+23 QUIT
+24 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+25 ;
NICKNM ; CHECK FIRST & MIDDLE NAMES FOR NICK NAMES
+1 SET AUPNML=$PIECE(AUPX,",",1)
SET AUPNMF=$PIECE($PIECE(AUPX,",",2)," ",1)
SET AUPNMM=$PIECE($PIECE(AUPX,",",2)," ",2)
SET AUPNMX=$PIECE(AUPX,",",3)
+2 IF AUPNMF'=""
IF $DATA(^APMM(99,"B",AUPNMF))
SET AUPNMCVN=1
FOR AUPNMCV=0:0
SET AUPNMCV=$ORDER(^APMM(99,"B",AUPNMF,AUPNMCV))
IF AUPNMCV=""
QUIT
DO NICKNM2
IF AUPNMCV=""
QUIT
+3 IF AUPNMM'=""
IF $DATA(^APMM(99,"B",AUPNMM))
SET AUPNMCVN=2
FOR AUPNMCV=0:0
SET AUPNMCV=$ORDER(^APMM(99,"B",AUPNMM,AUPNMCV))
IF AUPNMCV=""
QUIT
DO NICKNM2
IF AUPNMCV=""
QUIT
+4 SET AUPX=AUPNML_","_AUPNMF_$SELECT(AUPNMM'="":" "_AUPNMM,1:"")_$SELECT(AUPNMX'="":","_AUPNMX,1:"")
+5 KILL AUPNML,AUPNMF,AUPNMM,AUPNMCV,AUPNMCVN,AUPNMCVX,AUPNMX
+6 QUIT
+7 ;
NICKNM2 ; CHECK NICK NAMES
+1 SET AUPNMCVX=$SELECT(AUPNMCVN=1:AUPNMF,1:AUPNMM)
+2 IF AUPNMCVX=$PIECE(^APMM(99,AUPNMCV,0),U,1)
QUIT
+3 WRITE !," Do you want ",$SELECT(AUPNMCVN=1:AUPNMF,1:AUPNMM)," entered as ",$PIECE(^APMM(99,AUPNMCV,0),U,1)
+4 SET %=2
DO YN^DICN
+5 IF %=1
SET @($SELECT(AUPNMCVN=1:"AUPNMF",1:"AUPNMM"))=$PIECE(^APMM(99,AUPNMCV,0),U,1)
SET AUPNMCV=""
+6 KILL %,%Y
+7 QUIT
+8 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+9 ;
CHKID ; CHECK IDENTIFIERS
+1 IF $DATA(DIC("DR"))
QUIT
+2 SET AUPGID="^.02^.03^.09^"
+3 FOR AUPID=.02,.03,.09
DO CHKID1
IF AUPQF2
QUIT
+4 IF AUPQF2
QUIT
+5 FOR AUPID=0:0
SET AUPID=$ORDER(^DD(2,0,"ID",AUPID))
IF 'AUPID!(AUPQF2)
QUIT
IF '$FIND(AUPGID,U_AUPID_U)
SET AUPLID=""
SET AUP("DR")=AUP("DR")_";"_AUPID
+6 QUIT
+7 ;
CHKID1 ;
+1 SET AUP("DR")=$SELECT('$DATA(AUP("DR")):AUPID,1:AUP("DR")_";"_AUPID)
IF $DATA(^DD(2,AUPID,0))
SET AUPID0=^(0)
DO ASKID
IF '$DATA(X)
SET AUPQF2=4
+2 QUIT
+3 ;
ASKID WRITE !?3,"PATIENT ",$PIECE(AUPID0,U),": "
READ X:DTIME
IF '$TEST!(X?1"^")
WRITE !?6,*7,"<'",AUPX,"'> DELETED"
KILL X
QUIT
+1 IF X=""
IF AUPID=.09
SET AUPIDS(AUPID)=""
SET AUP("DR")=AUP("DR")_"////"_X
QUIT
+2 IF X["^"
IF $EXTRACT(X)["^"
WRITE !?6,*7,"Sorry, '^' not allowed!"
WRITE " ??"
GOTO ASKID
+3 IF X["?"!(X="")
IF X=""
WRITE *7," ??"
DO HLPID
GOTO ASKID
+4 IF $PIECE(AUPID0,U,2)["S"
FOR I=1:1
SET Y=$PIECE($PIECE(AUPID0,U,3),";",I)
IF Y=""
KILL X
IF Y=""
QUIT
IF $PIECE(Y,":",1)=X!($EXTRACT($PIECE(Y,":",2),1,$LENGTH(X))=X)
SET X=$PIECE(Y,":",1)
SET AUPSET=$PIECE(Y,":",2)
QUIT
+5 SET (DA,D0)=0
+6 XECUTE $PIECE(^DD(2,AUPID,0),U,5,99)
IF $DATA(X)
IF $DATA(AUPSET)
WRITE " ",AUPSET
SET AUPIDS(AUPID)=X
SET AUP("DR")=AUP("DR")_"////"_X
KILL AUPSET
QUIT
+7 IF '$DATA(X)&($PIECE(AUPID0,U,2)'["D")
WRITE *7," ??"
DO HLPID
+8 GOTO ASKID
+9 ;
HLPID IF $DATA(^DD(2,AUPID,.1))
WRITE !?5,^(.1)
IF $DATA(^DD(2,AUPID,3))
WRITE !?5,^(3)
IF $DATA(X)
IF X["?"
FOR I=0:0
SET I=$ORDER(^DD(2,AUPID,21,I))
IF 'I!(I>3&(X?1"?"))
QUIT
IF $DATA(^(I,0))
WRITE !?5,^(0)
IF I>2
IF X?1"?"
WRITE !?5,"..."
+1 IF $DATA(^DD(2,AUPID,4))
WRITE !?5,^(4)
IF $PIECE(AUPID0,U,2)["D"
SET X="?"
SET %DT="E"
DO ^%DT
+2 IF $PIECE(AUPID0,U,2)["S"
WRITE !?7,"CHOOSE FROM: "
FOR I=1:1
SET Y=$PIECE($PIECE(AUPID0,U,3),";",I)
IF Y=""
QUIT
WRITE !?7,$PIECE(Y,":",1),?15," ",$PIECE(Y,":",2)
+3 QUIT
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
DUPECHK ; CHECK FOR DUPLICATE PATIENTS
+1 IF $DATA(DIC("DR"))
QUIT
+2 DO ^AUPNLK3
IF AUPNLK3<0
SET AUPQF2=5
KILL AUPNLK3
+3 QUIT
