AGDICLK ; IHS/ASDS/EFG - DICTIONARY ENTRY LOOK-UP UTILITY ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
L1 ;
K AGPCC,AG("LKPRINT"),AG("LKDATA"),AG("LKERR"),AGL,AG("AGDENT"),AGNEW
G END:'$D(DR)!'$D(DIC)!'$D(DA)
S AGLK("I")=1
S DIC(1)=DIC
S DR(1)=DR
G END:+DR<.01!(+DIC<1)!(+DA<1)
I $D(^DD(DIC,DR,0)) S G=^DD(DIC,DR,0) G COMP:$P(G,"^",2)["C" I +$P(G,"^",2)>0 S AG("LKERR")=5 G END
L2 ;
I '$D(^DD(DIC(AGLK("I")),DR(AGLK("I")),0)) D G END
. S AG("LKERR")=3
S AGSUB=$P(^DD(DIC(AGLK("I")),DR(AGLK("I")),0),"^",4)
S AGPC(AGLK("I"))=$P(AGSUB,";",2)
S AGSUB(AGLK("I"))=$P(AGSUB,";",1)
I '$D(^DD(DIC(AGLK("I")),0,"UP")) G L4
L3 ;
S AG("LKERR")=4
S:$D(AG("DRENT1")) AG("DRENT")=0
G END:'$D(AG("DRENT"))
G END:AG("DRENT")'="0"&(+AG("DRENT")<0)
G END:AG("DRENT")\1'=AG("DRENT")
S:AG("DRENT")=0 AGNEW=""
K AG("LKERR")
S AGLK("I")=AGLK("I")+1
S DIC(AGLK("I"))=^DD(DIC(AGLK("I")-1),0,"UP")
S DR(AGLK("I"))=0
S DR(AGLK("I"))=$O(^DD(DIC(AGLK("I")),"SB",DIC(AGLK("I")-1),DR(AGLK("I"))))
G L2
L4 ;
S AGL=^DIC(DIC(AGLK("I")),0,"GL")_DA
S AGL(1)=AGL_",0)"
I '$D(@AGL(1)) D G END
. S AG("LKERR")=1
I AGLK("I")=1 D G L5
. K AG("DRENT")
F AGLK("J")=AGLK("I"):-1:2 D
. S AGL=AGL_","_AGSUB(AGLK("J"))
. S:AGLK("J")>2 AGL=AGL_",1"
L5 ;
S AGPCC=AGPC(1) I '$D(AG("DRENT")) S AG("DRENT")="" G L6
L5A ;
S AGL(0)=AGL_",0)" I '$D(@AGL(0)) S AG("LKERR")=6,AGL=AGL_",1,0)" G END
L5B ;
S AGDENT=$P(@AGL(0),"^",4) S:AGDENT="" AGDENT=0 I AGDENT=0!(AG("DRENT")>AGDENT) S AG("LKERR")=2 G END
L5BB ;
I $D(AG("DRENT1")) D DNT4 G L5E:AGDNT'="" S AG("LKERR")=2 G END
L5C ;
I AG("DRENT")>0 D DNT2 S AG("DRENT")=AGDNT G L5E:AGDNTT>0 S AG("LKERR")=2 G END
L5D ;
S AGL(0)=AGL_",0)" D DNT
L5E ;
S AG("DRENT")=","_AG("DRENT")
L6 ;
S AGL=AGL_AG("DRENT")_","_AGSUB(1)_")" I AGL[",," S AG("LKERR")=2,AGNEW="" G END
I '$D(@AGL) S AG("LKERR")=2,AGNEW="" G END
L6A ;
S (AG("LKPRINT"),AG("LKDATA"))=$P(@AGL,"^",AGPC(1)) G END:AG("LKPRINT")=""
L7 ;
S AGG=$P(G,"^",2),AGLK("H")=$P(G,"^",3) G SET:AGG["S",DATE:AGG["D",PTR:AGG["P",TRX:$D(^DD(DIC(1),DR(1),2))
END ;
K AG("DRENT"),AG("DRENT1"),D0
K AGDNT,AGDNTT,AGLK,AGLKH,AGG,AGGG,AGLL,AGSUB,AGPC
S:'$D(AG("LKPRINT"))&'$D(AG("LKERR")) AG("LKERR")=0
Q
DNT ;
S AGDNT=0
DNT1 ;
S AGLL=AGL_",AGDNT)",AGDNT=$O(@AGLL) Q:AGDNT'=+AGDNT S AG("DRENT")=AGDNT G DNT1
DNT2 ;
S (AGDNT,AGDNTT)=0
DNT3 ;
S AGLL=AGL_",AGDNT)",AGDNT=$O(@AGLL) Q:AGDNT="" S AGDNTT=AGDNTT+1 Q:AGDNTT=AG("DRENT") G DNT3
DNT4 ;
S AGDNT=0
DNT5 ;
S AGLL=AGL_",AGDNT)",AGDNT=$O(@AGLL) Q:AGDNT="" S:AGDNT=AG("DRENT1") AG("DRENT")=AGDNT Q:AG("DRENT")=AGDNT G DNT5
SET ;
F AGLK("I")=1:1 S AGGG=$P(AGLK("H"),";",AGLK("I")) G END:AGGG="" S:$P(AGGG,":",1)=AG("LKDATA") AG("LKPRINT")=$P(AGGG,":",2)
G END
DATE ;
S Y=AG("LKDATA")
D DD^%DT
S AG("LKPRINT")=Y
G END
PTR ;
S AGGG="^"_AGLK("H")_AG("LKDATA")_",0)" I '$D(@AGGG) S AG("LKERR")=7 G END
S AG("LKPRINT")=$P(@AGGG,"^",1) G END
COMP ;
S AGLKH=$E($P(G,";",2),3,999),D0=DA X AGLKH S AG("LKPRINT")=X G END
TRX ;
S Y=AG("LKDATA") X ^DD(DIC(1),DR(1),2) S AG("LKPRINT")=Y G END
AGDICLK ; IHS/ASDS/EFG - DICTIONARY ENTRY LOOK-UP UTILITY ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
L1 ;
+1 KILL AGPCC,AG("LKPRINT"),AG("LKDATA"),AG("LKERR"),AGL,AG("AGDENT"),AGNEW
+2 IF '$DATA(DR)!'$DATA(DIC)!'$DATA(DA)
GOTO END
+3 SET AGLK("I")=1
+4 SET DIC(1)=DIC
+5 SET DR(1)=DR
+6 IF +DR<.01!(+DIC<1)!(+DA<1)
GOTO END
+7 IF $DATA(^DD(DIC,DR,0))
SET G=^DD(DIC,DR,0)
IF $PIECE(G,"^",2)["C"
GOTO COMP
IF +$PIECE(G,"^",2)>0
SET AG("LKERR")=5
GOTO END
L2 ;
+1 IF '$DATA(^DD(DIC(AGLK("I")),DR(AGLK("I")),0))
Begin DoDot:1
+2 SET AG("LKERR")=3
End DoDot:1
GOTO END
+3 SET AGSUB=$PIECE(^DD(DIC(AGLK("I")),DR(AGLK("I")),0),"^",4)
+4 SET AGPC(AGLK("I"))=$PIECE(AGSUB,";",2)
+5 SET AGSUB(AGLK("I"))=$PIECE(AGSUB,";",1)
+6 IF '$DATA(^DD(DIC(AGLK("I")),0,"UP"))
GOTO L4
L3 ;
+1 SET AG("LKERR")=4
+2 IF $DATA(AG("DRENT1"))
SET AG("DRENT")=0
+3 IF '$DATA(AG("DRENT"))
GOTO END
+4 IF AG("DRENT")'="0"&(+AG("DRENT")<0)
GOTO END
+5 IF AG("DRENT")\1'=AG("DRENT")
GOTO END
+6 IF AG("DRENT")=0
SET AGNEW=""
+7 KILL AG("LKERR")
+8 SET AGLK("I")=AGLK("I")+1
+9 SET DIC(AGLK("I"))=^DD(DIC(AGLK("I")-1),0,"UP")
+10 SET DR(AGLK("I"))=0
+11 SET DR(AGLK("I"))=$ORDER(^DD(DIC(AGLK("I")),"SB",DIC(AGLK("I")-1),DR(AGLK("I"))))
+12 GOTO L2
L4 ;
+1 SET AGL=^DIC(DIC(AGLK("I")),0,"GL")_DA
+2 SET AGL(1)=AGL_",0)"
+3 IF '$DATA(@AGL(1))
Begin DoDot:1
+4 SET AG("LKERR")=1
End DoDot:1
GOTO END
+5 IF AGLK("I")=1
Begin DoDot:1
+6 KILL AG("DRENT")
End DoDot:1
GOTO L5
+7 FOR AGLK("J")=AGLK("I"):-1:2
Begin DoDot:1
+8 SET AGL=AGL_","_AGSUB(AGLK("J"))
+9 IF AGLK("J")>2
SET AGL=AGL_",1"
End DoDot:1
L5 ;
+1 SET AGPCC=AGPC(1)
IF '$DATA(AG("DRENT"))
SET AG("DRENT")=""
GOTO L6
L5A ;
+1 SET AGL(0)=AGL_",0)"
IF '$DATA(@AGL(0))
SET AG("LKERR")=6
SET AGL=AGL_",1,0)"
GOTO END
L5B ;
+1 SET AGDENT=$PIECE(@AGL(0),"^",4)
IF AGDENT=""
SET AGDENT=0
IF AGDENT=0!(AG("DRENT")>AGDENT)
SET AG("LKERR")=2
GOTO END
L5BB ;
+1 IF $DATA(AG("DRENT1"))
DO DNT4
IF AGDNT'=""
GOTO L5E
SET AG("LKERR")=2
GOTO END
L5C ;
+1 IF AG("DRENT")>0
DO DNT2
SET AG("DRENT")=AGDNT
IF AGDNTT>0
GOTO L5E
SET AG("LKERR")=2
GOTO END
L5D ;
+1 SET AGL(0)=AGL_",0)"
DO DNT
L5E ;
+1 SET AG("DRENT")=","_AG("DRENT")
L6 ;
+1 SET AGL=AGL_AG("DRENT")_","_AGSUB(1)_")"
IF AGL[",,"
SET AG("LKERR")=2
SET AGNEW=""
GOTO END
+2 IF '$DATA(@AGL)
SET AG("LKERR")=2
SET AGNEW=""
GOTO END
L6A ;
+1 SET (AG("LKPRINT"),AG("LKDATA"))=$PIECE(@AGL,"^",AGPC(1))
IF AG("LKPRINT")=""
GOTO END
L7 ;
+1 SET AGG=$PIECE(G,"^",2)
SET AGLK("H")=$PIECE(G,"^",3)
IF AGG["S"
GOTO SET
IF AGG["D"
GOTO DATE
IF AGG["P"
GOTO PTR
IF $DATA(^DD(DIC(1),DR(1),2))
GOTO TRX
END ;
+1 KILL AG("DRENT"),AG("DRENT1"),D0
+2 KILL AGDNT,AGDNTT,AGLK,AGLKH,AGG,AGGG,AGLL,AGSUB,AGPC
+3 IF '$DATA(AG("LKPRINT"))&'$DATA(AG("LKERR"))
SET AG("LKERR")=0
+4 QUIT
DNT ;
+1 SET AGDNT=0
DNT1 ;
+1 SET AGLL=AGL_",AGDNT)"
SET AGDNT=$ORDER(@AGLL)
IF AGDNT'=+AGDNT
QUIT
SET AG("DRENT")=AGDNT
GOTO DNT1
DNT2 ;
+1 SET (AGDNT,AGDNTT)=0
DNT3 ;
+1 SET AGLL=AGL_",AGDNT)"
SET AGDNT=$ORDER(@AGLL)
IF AGDNT=""
QUIT
SET AGDNTT=AGDNTT+1
IF AGDNTT=AG("DRENT")
QUIT
GOTO DNT3
DNT4 ;
+1 SET AGDNT=0
DNT5 ;
+1 SET AGLL=AGL_",AGDNT)"
SET AGDNT=$ORDER(@AGLL)
IF AGDNT=""
QUIT
IF AGDNT=AG("DRENT1")
SET AG("DRENT")=AGDNT
IF AG("DRENT")=AGDNT
QUIT
GOTO DNT5
SET ;
+1 FOR AGLK("I")=1:1
SET AGGG=$PIECE(AGLK("H"),";",AGLK("I"))
IF AGGG=""
GOTO END
IF $PIECE(AGGG,"
SET AG("LKPRINT")=$PIECE(AGGG,":",2)
+2 GOTO END
DATE ;
+1 SET Y=AG("LKDATA")
+2 DO DD^%DT
+3 SET AG("LKPRINT")=Y
+4 GOTO END
PTR ;
+1 SET AGGG="^"_AGLK("H")_AG("LKDATA")_",0)"
IF '$DATA(@AGGG)
SET AG("LKERR")=7
GOTO END
+2 SET AG("LKPRINT")=$PIECE(@AGGG,"^",1)
GOTO END
COMP ;
+1 SET AGLKH=$EXTRACT($PIECE(G,";",2),3,999)
SET D0=DA
XECUTE AGLKH
SET AG("LKPRINT")=X
GOTO END
TRX ;
+1 SET Y=AG("LKDATA")
XECUTE ^DD(DIC(1),DR(1),2)
SET AG("LKPRINT")=Y
GOTO END
