- AGGWOTH ;VNGT/HS/ALA-Other AGG Window RPCs ; 18 May 2010 1:32 PM
- ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
- ;
- ;
- LANG(DATA,DFN) ; EP - AGG PATIENT LANGUAGES
- ;
- NEW UID,II,AGIEN,LDA
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("AGGWLANG",UID))
- K @DATA
- S II=0
- NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
- ;
- S AGIEN=$$FIND1^DIC(9009068.3,"","BX","Other Languages","","","ERROR")
- I AGIEN=0 S BMXSEC="RPC Failed: Passed in window name "_DEF_" not found" Q
- ;
- S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,AGIEN,0),U,14)
- ;
- S DA(1)=DFN,LDA=$O(^AUPNPAT(DFN,86,"B"),-1) I 'LDA D G DONE
- . S HEADR="T00040AGGLGOTH^I00010LGIEN",HDATA=""
- . S @DATA@(II)=HEADR_$C(30)
- . ;S II=II+1,@DATA@(II)=HDATA_$C(30)
- ;
- S IEN=0
- I $O(^AUPNPAT(DFN,86,LDA,5,IEN))="" D G DONE
- . S HEADR="T00040AGGLGOTH^I00010LGIEN",HDATA=""
- . S @DATA@(II)=HEADR_$C(30)
- . ;S II=II+1,@DATA@(II)=HDATA_$C(30)
- ;
- F S IEN=$O(^AUPNPAT(DFN,86,LDA,5,IEN)) Q:'IEN D
- . S DA(2)=DFN,DA(1)=LDA,DA=IEN
- . S IENS=$$IENS^DILF(.DA)
- . S HEADR="",HDATA=""
- . D REC(IENS)
- ;
- DONE ;
- S II=II+1,@DATA@(II)=$C(31)
- ;
- Q
- ;
- REC(IENS) ;EP
- S AGCN=0
- F S AGCN=$O(^AGG(9009068.3,AGIEN,10,AGCN)) Q:'AGCN D
- . I $P(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'="" Q
- . S AGDATA=$G(^AGG(9009068.3,AGIEN,10,AGCN,0))
- . S FLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,7)
- . S TYPE=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
- . S CODE=$P(AGDATA,U,7),HDR=$P(AGDATA,U,2)
- . S DEXEC=$G(^AGG(9009068.3,AGIEN,10,AGCN,8))
- . I TYPE="M" S VALUE=""
- . I TYPE="T"!(TYPE="C") D
- .. I DEXEC'="" D Q
- ... S VAL=""
- ... I DEXEC'["DQTY" X DEXEC Q
- ... S DQTY="I" X DEXEC S VAL=VALUE_$C(28)
- ... S DQTY="E" X DEXEC S VALUE=VAL_VALUE
- .. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(FILE,IENS,FLD,"E") Q
- .. S VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")_$C(28)_$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
- . I TYPE="X"!(TYPE="N") D
- .. NEW TYPE
- .. I DEXEC'="" X DEXEC Q
- .. I FLD=.001 S VALUE=IEN Q
- .. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E") Q
- .. S VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
- . I TYPE="D" D
- .. I DEXEC'="" X DEXEC Q
- .. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE) Q
- .. S VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE)
- . I TYPE="W" D
- .. NEW FL,FD
- .. K ARRAY S VALUE=""
- .. I DEXEC'="" X DEXEC
- .. I DEXEC="" D
- ... I FLD'="" D GETS^DIQ(FILE,DFN_",",FLD,"E","ARRAY") Q
- ... D GETS^DIQ(SECFILE,DFN_",",SECFLD,"E","ARRAY")
- .. S FL=$O(ARRAY("")) I FL="" Q
- .. S FD=$O(ARRAY(FL,DFN_",","")) I FD="" Q
- .. S AN=0,TXT=ARRAY(FL,DFN_",",FD,"E") I TXT="" Q
- .. K @TXT@("E")
- .. F S AN=$O(@TXT@(AN)) Q:AN="" S VALUE=VALUE_@TXT@(AN)_$C(10)
- . S HEADR=HEADR_HDR_"^"
- . S HDATA=HDATA_$G(VALUE)_"^",VALUE=""
- S HEADR=$$TKO^AGGUL1(HEADR,"^"),HDATA=$$TKO^AGGUL1(HDATA,"^")
- I II=0 S @DATA@(II)=HEADR_$C(30)
- S II=II+1,@DATA@(II)=HDATA_$C(30)
- ;
- Q
- ;
- ERR ;
- D ^%ZTER
- NEW Y,ERRDTM
- S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
- S BMXSEC="Recording that an error occurred at "_ERRDTM
- I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
- Q
- AGGWOTH ;VNGT/HS/ALA-Other AGG Window RPCs ; 18 May 2010 1:32 PM
- +1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
- +2 ;
- +3 ;
- LANG(DATA,DFN) ; EP - AGG PATIENT LANGUAGES
- +1 ;
- +2 NEW UID,II,AGIEN,LDA
- +3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +4 SET DATA=$NAME(^TMP("AGGWLANG",UID))
- +5 KILL @DATA
- +6 SET II=0
- +7 ; SAC 2006 2.2.3.3.2
- NEW $ESTACK,$ETRAP
- SET $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER"
- +8 ;
- +9 SET AGIEN=$$FIND1^DIC(9009068.3,"","BX","Other Languages","","","ERROR")
- +10 IF AGIEN=0
- SET BMXSEC="RPC Failed: Passed in window name "_DEF_" not found"
- QUIT
- +11 ;
- +12 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
- SET SECFILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,14)
- +13 ;
- +14 SET DA(1)=DFN
- SET LDA=$ORDER(^AUPNPAT(DFN,86,"B"),-1)
- IF 'LDA
- Begin DoDot:1
- +15 SET HEADR="T00040AGGLGOTH^I00010LGIEN"
- SET HDATA=""
- +16 SET @DATA@(II)=HEADR_$CHAR(30)
- +17 ;S II=II+1,@DATA@(II)=HDATA_$C(30)
- End DoDot:1
- GOTO DONE
- +18 ;
- +19 SET IEN=0
- +20 IF $ORDER(^AUPNPAT(DFN,86,LDA,5,IEN))=""
- Begin DoDot:1
- +21 SET HEADR="T00040AGGLGOTH^I00010LGIEN"
- SET HDATA=""
- +22 SET @DATA@(II)=HEADR_$CHAR(30)
- +23 ;S II=II+1,@DATA@(II)=HDATA_$C(30)
- End DoDot:1
- GOTO DONE
- +24 ;
- +25 FOR
- SET IEN=$ORDER(^AUPNPAT(DFN,86,LDA,5,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:1
- +26 SET DA(2)=DFN
- SET DA(1)=LDA
- SET DA=IEN
- +27 SET IENS=$$IENS^DILF(.DA)
- +28 SET HEADR=""
- SET HDATA=""
- +29 DO REC(IENS)
- End DoDot:1
- +30 ;
- DONE ;
- +1 SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +2 ;
- +3 QUIT
- +4 ;
- REC(IENS) ;EP
- +1 SET AGCN=0
- +2 FOR
- SET AGCN=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN))
- IF 'AGCN
- QUIT
- Begin DoDot:1
- +3 IF $PIECE(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'=""
- QUIT
- +4 SET AGDATA=$GET(^AGG(9009068.3,AGIEN,10,AGCN,0))
- +5 SET FLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1)
- SET SECFLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,7)
- +6 SET TYPE=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
- +7 SET CODE=$PIECE(AGDATA,U,7)
- SET HDR=$PIECE(AGDATA,U,2)
- +8 SET DEXEC=$GET(^AGG(9009068.3,AGIEN,10,AGCN,8))
- +9 IF TYPE="M"
- SET VALUE=""
- +10 IF TYPE="T"!(TYPE="C")
- Begin DoDot:2
- +11 IF DEXEC'=""
- Begin DoDot:3
- +12 SET VAL=""
- +13 IF DEXEC'["DQTY"
- XECUTE DEXEC
- QUIT
- +14 SET DQTY="I"
- XECUTE DEXEC
- SET VAL=VALUE_$CHAR(28)
- +15 SET DQTY="E"
- XECUTE DEXEC
- SET VALUE=VAL_VALUE
- End DoDot:3
- QUIT
- +16 IF FLD'=""
- SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$CHAR(28)_$$GET1^DIQ(FILE,IENS,FLD,"E")
- QUIT
- +17 SET VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")_$CHAR(28)_$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
- End DoDot:2
- +18 IF TYPE="X"!(TYPE="N")
- Begin DoDot:2
- +19 NEW TYPE
- +20 IF DEXEC'=""
- XECUTE DEXEC
- QUIT
- +21 IF FLD=.001
- SET VALUE=IEN
- QUIT
- +22 IF FLD'=""
- SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E")
- QUIT
- +23 SET VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
- End DoDot:2
- +24 IF TYPE="D"
- Begin DoDot:2
- +25 IF DEXEC'=""
- XECUTE DEXEC
- QUIT
- +26 IF FLD'=""
- SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")
- SET VALUE=$$FMTE^AGGUL1(VALUE)
- QUIT
- +27 SET VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")
- SET VALUE=$$FMTE^AGGUL1(VALUE)
- End DoDot:2
- +28 IF TYPE="W"
- Begin DoDot:2
- +29 NEW FL,FD
- +30 KILL ARRAY
- SET VALUE=""
- +31 IF DEXEC'=""
- XECUTE DEXEC
- +32 IF DEXEC=""
- Begin DoDot:3
- +33 IF FLD'=""
- DO GETS^DIQ(FILE,DFN_",",FLD,"E","ARRAY")
- QUIT
- +34 DO GETS^DIQ(SECFILE,DFN_",",SECFLD,"E","ARRAY")
- End DoDot:3
- +35 SET FL=$ORDER(ARRAY(""))
- IF FL=""
- QUIT
- +36 SET FD=$ORDER(ARRAY(FL,DFN_",",""))
- IF FD=""
- QUIT
- +37 SET AN=0
- SET TXT=ARRAY(FL,DFN_",",FD,"E")
- IF TXT=""
- QUIT
- +38 KILL @TXT@("E")
- +39 FOR
- SET AN=$ORDER(@TXT@(AN))
- IF AN=""
- QUIT
- SET VALUE=VALUE_@TXT@(AN)_$CHAR(10)
- End DoDot:2
- +40 SET HEADR=HEADR_HDR_"^"
- +41 SET HDATA=HDATA_$GET(VALUE)_"^"
- SET VALUE=""
- End DoDot:1
- +42 SET HEADR=$$TKO^AGGUL1(HEADR,"^")
- SET HDATA=$$TKO^AGGUL1(HDATA,"^")
- +43 IF II=0
- SET @DATA@(II)=HEADR_$CHAR(30)
- +44 SET II=II+1
- SET @DATA@(II)=HDATA_$CHAR(30)
- +45 ;
- +46 QUIT
- +47 ;
- ERR ;
- +1 DO ^%ZTER
- +2 NEW Y,ERRDTM
- +3 SET Y=$$NOW^XLFDT()
- XECUTE ^DD("DD")
- SET ERRDTM=Y
- +4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
- +5 IF $DATA(II)
- IF $DATA(DATA)
- SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +6 QUIT
