AQALNK ; IHS/ORDC/LJF - CREATES OCC FROM OTHER PKGS ;
;;1;QI LINKAGES-RPMS;;AUG 15, 1994
;
;This rtn is available to RPMS packages that wish to automatically
;create occurrence entries. The input variables are:
;
; AQALNK("PAT")=patient's DFN (required)
; AQALNK("IND")=internal entry # for indicator (required)
; AQALNK("DATE")=occurrence date (required)
; AQALNK("VSIT")=visit internal number (optional but recommended)
; AQALNK("HSV")=hospital service for visit (required but can be null)
; AQALNK("WARD")=ward moved into for admits, out of for others
; AQALNK("FAC")=facility internal number (required if no visit #)
; AQALNK("DUP OK")=if defined, allows adding duplicate occurrence
; AQALNK("BUL")=name of error bulletin
; AQALXTR array for data to be stuffed into case summary field
;
;The output variables will include those listed above AND
; AQALIFN=occurrence internal entry number OR
; AQALNKF("NO GO")=set if occurrence not created PLUS
; AQALNKF("PAT")=if set, describes patient error
; AQALNKF("IND")=if set, describes indicator error
; AQALNKF("DATE")=if set, describes occurrence date error
; AQALNKF("VSIT")=if set, describes visit error
; AQALNKF("FAC")=if set, describes facility error
;
;The calling routine will be responsible for killing the variables
;described above. This routine will kill all other AQA variables used.
;The published entry point is CREATE^AQALNK.
;
CREATE ;PEP; PUBLIC ENTRY POINT to create occurrences
; >>> check input variables
K AQALNKF,AQALIFN
F I="PAT","IND","DATE","FAC" D
.I '$D(AQALNK(I)) S AQALNKF(I)="Variable AQALNK("_I_") is missing" Q
.I AQALNK(I)="" S AQALNKF(I)="Variable set but null"
I $D(AQALNKF) G EXIT ;quit if error flags set
;
D VARCHECK ;check validity of input variables
I $D(AQALNKF) G EXIT ;quit if error flags set
I '$D(AQALNK("VSIT")) S AQALNK("VSIT")=""
;
DUPCHECK ; >>> check if duplicate entry allowed
I $D(AQALNK("DUP OK")) G ADD ;okay to add duplicate entry
; ;quit if occurrence already exists
G EXIT:$D(^AQAOC("AA",AQALNK("IND"),AQALNK("DATE"),AQALNK("PAT")))
;
ADD ; >>> set variables and call file^dicn
S AQALPAT=AQALNK("PAT"),AQALDATE=AQALNK("DATE"),AQALIND=AQALNK("IND")
S AQAODATE=AQALDATE,AQAOPAT=AQALPAT,AQAOIND=AQALIND
S AQALCID=$$OCCID^AQAOCID ;create occ id number
I '$D(AQALCID) S AQALNKF("NO GO")="Couldn't create occ ID #" G EXIT
;
K DD,DO,DIC S DIC="^AQAOC(",DIC(0)="L",X=AQALCID
S DIC("DR")=".02////"_AQALPAT_";.03////"_AQALNK("VSIT")_";.04////"_AQALDATE_";.06////"_AQALNK("WARD")_";.07////"_AQALNK("HSV")_";.08////"_AQALIND_";.09////"_AQALNK("FAC")_";.011////1;.11////0"
L +(^AQAOC(0)):1 I '$T D G EXIT
.S AQALNKF("NO GO")="Occurrence file locked; could not add"
L +(^AQAGU(0)):1 I '$T D G EXIT
.S AQALNKF("NO GO")="QI Audit file locked; could not add"
D FILE^DICN L -(^AQAOC(0))
I Y=-1 S AQALNKF("NO GO")="Add thru FILE^DICN didn't work" G EXIT
S AQALIFN=+Y
;
AUDIT S AQAOUDIT("DA")=AQALIFN,AQAOUDIT("ACTION")="O"
S AQAOUDIT("COMMENT")="OPEN A RECORD-AUTO LINK" D ^AQAOAUD
;
SUMM ; >>> add xtra data to case summary wp field
G EXIT:$O(^AQAOC(AQALIFN,"CASE",0)) ;already data in case summary field
S (AQALSTX,AQALST)=0
F S AQALST=$O(AQALXTR(AQALST)) Q:AQALST="" D
.S ^AQAOC(AQALIFN,"CASE",AQALST,0)=AQALXTR(AQALST),AQALSTX=AQALST
S:+AQALSTX ^AQAOC(AQALIFN,"CASE",0)=U_U_AQALSTX_U_AQALSTX_DT
;
EXIT ; >>> eoj
K AQAOPAT,AQAODATE,AQAOIND,DIC,X,Y,I
I $D(AQALNKF),$D(AQALNK("BUL")) D ^AQALNKER Q ;send error bulletin
W !!,"QAI Occurrence created for this transaction: "
W "(",$P($P(^DD(AQALF,AQALEV,0),U),"LINK"),")",!
Q
;
;
VARCHECK ;EP >>> SUBRTN to check input variables
;called by this rtn and ^AQALNK1
I '$D(^DPT(AQALNK("PAT"),0)) S AQALNKF("PAT")="Bad patient DFN" Q
S:$P(^DPT(AQALNK("PAT"),0),U,19)'="" AQALNKF("PAT")="Merged Patient"
S:'$D(^AQAO(2,AQALNK("IND"),0)) AQALNKF("IND")="Bad indicator ifn" Q
S:$P(^AQAO(2,AQALNK("IND"),0),U,6)="I" AQALNKF("IND")="Inactive indicator"
I $G(AQALNK("VSIT"))>0 D
.S:'$D(^AUPNVSIT(AQALNK("VSIT"),0)) AQALNKF("VSIT")="Bad visit ifn" Q
.S X=^AUPNVSIT(AQALNK("VSIT"),0) ;set visit node
.S:$P(X,U,11)=1 AQALNKF("VSIT")="Deleted visit"
.S:$P(X,U,5)'=AQALNK("PAT") AQALNKF("VSIT")="Visit not for patient"
S:'$D(^APCDSITE("B",AQALNK("FAC"))) AQALNKF("FAC")="Not PCC site"
S:'$D(^AUPNPAT(AQALNK("PAT"),41,AQALNK("FAC"),0)) AQALNKF("FAC")="Patient doesn't have chart # for facility"
S X=AQALNK("DATE") I +X<1000000 S AQALNKF("DATE")="Invalid date"
I (X<1000000)!(X>DT) S AQALNKF("DATE")="Can't have future dates"
I X<$P(^DPT(AQALNK("PAT"),0),U,3) S AQALNKF("DATE")="Occ before DOB"
Q:'$D(^DPT(AQALNK("PAT"),.35)) I $P(^(.35),U)="" Q ;not dead
I X>+^DPT(AQALNK("PAT"),.35) S AQALNKF("DATE")="Occ after DOD"
Q
AQALNK ; IHS/ORDC/LJF - CREATES OCC FROM OTHER PKGS ;
+1 ;;1;QI LINKAGES-RPMS;;AUG 15, 1994
+2 ;
+3 ;This rtn is available to RPMS packages that wish to automatically
+4 ;create occurrence entries. The input variables are:
+5 ;
+6 ; AQALNK("PAT")=patient's DFN (required)
+7 ; AQALNK("IND")=internal entry # for indicator (required)
+8 ; AQALNK("DATE")=occurrence date (required)
+9 ; AQALNK("VSIT")=visit internal number (optional but recommended)
+10 ; AQALNK("HSV")=hospital service for visit (required but can be null)
+11 ; AQALNK("WARD")=ward moved into for admits, out of for others
+12 ; AQALNK("FAC")=facility internal number (required if no visit #)
+13 ; AQALNK("DUP OK")=if defined, allows adding duplicate occurrence
+14 ; AQALNK("BUL")=name of error bulletin
+15 ; AQALXTR array for data to be stuffed into case summary field
+16 ;
+17 ;The output variables will include those listed above AND
+18 ; AQALIFN=occurrence internal entry number OR
+19 ; AQALNKF("NO GO")=set if occurrence not created PLUS
+20 ; AQALNKF("PAT")=if set, describes patient error
+21 ; AQALNKF("IND")=if set, describes indicator error
+22 ; AQALNKF("DATE")=if set, describes occurrence date error
+23 ; AQALNKF("VSIT")=if set, describes visit error
+24 ; AQALNKF("FAC")=if set, describes facility error
+25 ;
+26 ;The calling routine will be responsible for killing the variables
+27 ;described above. This routine will kill all other AQA variables used.
+28 ;The published entry point is CREATE^AQALNK.
+29 ;
CREATE ;PEP; PUBLIC ENTRY POINT to create occurrences
+1 ; >>> check input variables
+2 KILL AQALNKF,AQALIFN
+3 FOR I="PAT","IND","DATE","FAC"
Begin DoDot:1
+4 IF '$DATA(AQALNK(I))
SET AQALNKF(I)="Variable AQALNK("_I_") is missing"
QUIT
+5 IF AQALNK(I)=""
SET AQALNKF(I)="Variable set but null"
End DoDot:1
+6 ;quit if error flags set
IF $DATA(AQALNKF)
GOTO EXIT
+7 ;
+8 ;check validity of input variables
DO VARCHECK
+9 ;quit if error flags set
IF $DATA(AQALNKF)
GOTO EXIT
+10 IF '$DATA(AQALNK("VSIT"))
SET AQALNK("VSIT")=""
+11 ;
DUPCHECK ; >>> check if duplicate entry allowed
+1 ;okay to add duplicate entry
IF $DATA(AQALNK("DUP OK"))
GOTO ADD
+2 ; ;quit if occurrence already exists
+3 IF $DATA(^AQAOC("AA",AQALNK("IND"),AQALNK("DATE"),AQALNK("PAT")))
GOTO EXIT
+4 ;
ADD ; >>> set variables and call file^dicn
+1 SET AQALPAT=AQALNK("PAT")
SET AQALDATE=AQALNK("DATE")
SET AQALIND=AQALNK("IND")
+2 SET AQAODATE=AQALDATE
SET AQAOPAT=AQALPAT
SET AQAOIND=AQALIND
+3 ;create occ id number
SET AQALCID=$$OCCID^AQAOCID
+4 IF '$DATA(AQALCID)
SET AQALNKF("NO GO")="Couldn't create occ ID #"
GOTO EXIT
+5 ;
+6 KILL DD,DO,DIC
SET DIC="^AQAOC("
SET DIC(0)="L"
SET X=AQALCID
+7 SET DIC("DR")=".02////"_AQALPAT_";.03////"_AQALNK("VSIT")_";.04////"_AQALDATE_";.06////"_AQALNK("WARD")_";.07////"_AQALNK("HSV")_";.08////"_AQALIND_";.09////"_AQALNK("FAC")_";.011////1;.11////0"
+8 LOCK +(^AQAOC(0)):1
IF '$TEST
Begin DoDot:1
+9 SET AQALNKF("NO GO")="Occurrence file locked; could not add"
End DoDot:1
GOTO EXIT
+10 LOCK +(^AQAGU(0)):1
IF '$TEST
Begin DoDot:1
+11 SET AQALNKF("NO GO")="QI Audit file locked; could not add"
End DoDot:1
GOTO EXIT
+12 DO FILE^DICN
LOCK -(^AQAOC(0))
+13 IF Y=-1
SET AQALNKF("NO GO")="Add thru FILE^DICN didn't work"
GOTO EXIT
+14 SET AQALIFN=+Y
+15 ;
AUDIT SET AQAOUDIT("DA")=AQALIFN
SET AQAOUDIT("ACTION")="O"
+1 SET AQAOUDIT("COMMENT")="OPEN A RECORD-AUTO LINK"
DO ^AQAOAUD
+2 ;
SUMM ; >>> add xtra data to case summary wp field
+1 ;already data in case summary field
IF $ORDER(^AQAOC(AQALIFN,"CASE",0))
GOTO EXIT
+2 SET (AQALSTX,AQALST)=0
+3 FOR
SET AQALST=$ORDER(AQALXTR(AQALST))
IF AQALST=""
QUIT
Begin DoDot:1
+4 SET ^AQAOC(AQALIFN,"CASE",AQALST,0)=AQALXTR(AQALST)
SET AQALSTX=AQALST
End DoDot:1
+5 IF +AQALSTX
SET ^AQAOC(AQALIFN,"CASE",0)=U_U_AQALSTX_U_AQALSTX_DT
+6 ;
EXIT ; >>> eoj
+1 KILL AQAOPAT,AQAODATE,AQAOIND,DIC,X,Y,I
+2 ;send error bulletin
IF $DATA(AQALNKF)
IF $DATA(AQALNK("BUL"))
DO ^AQALNKER
QUIT
+3 WRITE !!,"QAI Occurrence created for this transaction: "
+4 WRITE "(",$PIECE($PIECE(^DD(AQALF,AQALEV,0),U),"LINK"),")",!
+5 QUIT
+6 ;
+7 ;
VARCHECK ;EP >>> SUBRTN to check input variables
+1 ;called by this rtn and ^AQALNK1
+2 IF '$DATA(^DPT(AQALNK("PAT"),0))
SET AQALNKF("PAT")="Bad patient DFN"
QUIT
+3 IF $PIECE(^DPT(AQALNK("PAT"),0),U,19)'=""
SET AQALNKF("PAT")="Merged Patient"
+4 IF '$DATA(^AQAO(2,AQALNK("IND"),0))
SET AQALNKF("IND")="Bad indicator ifn"
QUIT
+5 IF $PIECE(^AQAO(2,AQALNK("IND"),0),U,6)="I"
SET AQALNKF("IND")="Inactive indicator"
+6 IF $GET(AQALNK("VSIT"))>0
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(AQALNK("VSIT"),0))
SET AQALNKF("VSIT")="Bad visit ifn"
QUIT
+8 ;set visit node
SET X=^AUPNVSIT(AQALNK("VSIT"),0)
+9 IF $PIECE(X,U,11)=1
SET AQALNKF("VSIT")="Deleted visit"
+10 IF $PIECE(X,U,5)'=AQALNK("PAT")
SET AQALNKF("VSIT")="Visit not for patient"
End DoDot:1
+11 IF '$DATA(^APCDSITE("B",AQALNK("FAC")))
SET AQALNKF("FAC")="Not PCC site"
+12 IF '$DATA(^AUPNPAT(AQALNK("PAT"),41,AQALNK("FAC"),0))
SET AQALNKF("FAC")="Patient doesn't have chart # for facility"
+13 SET X=AQALNK("DATE")
IF +X<1000000
SET AQALNKF("DATE")="Invalid date"
+14 IF (X<1000000)!(X>DT)
SET AQALNKF("DATE")="Can't have future dates"
+15 IF X<$PIECE(^DPT(AQALNK("PAT"),0),U,3)
SET AQALNKF("DATE")="Occ before DOB"
+16 ;not dead
IF '$DATA(^DPT(AQALNK("PAT"),.35))
QUIT
IF $PIECE(^(.35),U)=""
QUIT
+17 IF X>+^DPT(AQALNK("PAT"),.35)
SET AQALNKF("DATE")="Occ after DOD"
+18 QUIT
