- 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
