- BQITRPPT ;PRXM/HC/ALA-Treatment Prompt ; 24 Apr 2007 11:47 AM
- ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
- ;
- Q
- ;
- FND(BQTRMT,BQGLOB,BQDFN,BQRM) ;EP
- ;
- ; Input Parameters
- ; BQTRMT - Treatment Prompt
- ; BQGLOB - Reference to store data
- ; BQDFN - Patient IEN
- ; BQRM - Remarks array
- ; Output Parameter
- ; MEET - If zero, didn't meet the criteria
- ; If one, did meet the criteria
- ;
- NEW BQREF,CEXE,MEET,N,TAX,NIT,TMFRAME,FREF,ABS,CONT,GREF,TREF,IEN,TIEN,EXEC
- NEW CEXEC,BQIAND,BQIOR
- ;S BQREF="BQIRY" K @BQREF
- ;D BLD(BQTRMT,BQREF,.CEXEC)
- ;
- ; Find if there is a special executable for the treatment prompt
- S EXEC=$G(^BQI(90508.5,BQTRMT,2))
- I $G(EXEC)'="" X EXEC
- ; EXEC should always return RESULT
- ;
- ; update remarks if patient passed all the checks
- I $P(RESULT,U,1)=1 D
- . K PARMS
- . ; Set the parameter values returned from API
- . F BN=3:1:$L(RESULT,U) S PARMS(BN-2)=$P(RESULT,U,BN)
- . S BN=0
- . F S BN=$O(BQRM(BN)) Q:BN="" D
- .. I BQRM(BN)'["|" Q
- .. ; Apply parameters into remarks
- .. S NDESC=BQRM(BN)
- .. F Q:'$F(NDESC,"|") D PRS
- .. S BQRM(BN)=PDESC
- Q RESULT
- ;
- S MEET=1
- ;
- ; If taxonomy checks are used to determine whether patient meets criteria or not
- I $D(@BQREF) D
- . S N=0 F S N=$O(@BQREF@(N)) Q:'N D
- .. S TAX=$P(@BQREF@(N),U,1),NIT=$P(@BQREF@(N),U,2)
- .. S TMFRAME=$P(@BQREF@(N),U,3),FREF=$P(@BQREF@(N),U,4)
- .. I TMFRAME'="" S EDATE=$$DATE^BQIUL1(TMFRAME),BDATE=DT
- .. I TMFRAME="" S EDATE=$$DATE^BQIUL1("T-12M"),BDATE=DT
- .. S ABS=$P(@BQREF@(N),U,5),CONT=+$P(@BQREF@(N),U,6)
- .. ;
- .. ; Check for a contraindication executable
- .. S CEXE=$G(CEXEC(N))
- .. I $G(CEXE)'="" D Q
- ... S DFN=BQDFN
- ... ;I $G(DFN)="" S DFN=BQDFN
- ... X CEXE
- ... ;
- ... ; If absence/presence is defined
- ... I ABS'="" D
- .... I 'X,'ABS S MEET=1 Q
- .... I 'X,ABS S MEET=0 Q
- .... I X,'ABS S MEET=0 Q
- .... I X,ABS S MEET=1
- ... ; If absence/presence is not defined
- ... I ABS="" D
- .... I X S MEET=1 Q
- .... I 'X S MEET=0
- ... ;I MEET,X,CONT S MEET=0
- ... ;I MEET,X,'CONT S MEET=1
- ... ;I MEET,'X,'CONT S MEET=0
- ... ; If met criteria but also met contraindication
- ... I MEET,CONT S MEET=0
- ... I MEET,'CONT S MEET=1
- ... I 'MEET,CONT S MEET=1
- ... I 'MEET,'CONT S MEET=0
- ... ;
- ... Q:'MEET
- ... ; update remarks if patient passed all the checks
- ... K PARMS
- ... F BN=2:1:$L(X,U) S PARMS(BN-1)=$P(X,U,BN)
- ... S BN=0
- ... F S BN=$O(BQRM(BN)) Q:BN="" D
- .... I BQRM(BN)'["|" Q
- .... S NDESC=BQRM(BN)
- .... F Q:'$F(NDESC,"|") D PRS
- .... ;I PDESC["~"
- .... S BQRM(BN)=PDESC
- .. ;
- .. S GREF=$$ROOT^DILFD(FREF,"",1),TREF=$NA(^TMP("BQITAX",UID))
- .. ; Build the taxonomy reference
- .. K @TREF
- .. Q:TAX=""
- .. D BLD^BQITUTL(TAX,TREF)
- .. S IEN="",QFL=0
- .. F S IEN=$O(@GREF@("AC",BQDFN,IEN),-1) Q:IEN="" D Q:QFL
- ... S TIEN=$$GET1^DIQ(FREF,IEN_",",.01,"I") I TIEN="" Q
- ... I '$D(@TREF@(TIEN)) Q
- ... S VISIT=$$GET1^DIQ(FREF,IEN_",",.03,"I") I VISIT="" Q
- ... I $$GET1^DIQ(9000010,VISIT_",",.11,"I")=1 Q
- ... S VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I")\1 I VSDTM=0 Q
- ... I $G(TMFRAME)'="",VSDTM<EDATE Q
- ... ; If absence of data, then it did not meet the criteria
- ... I ABS=0 S MEET=0,QFL=1 Q
- ... S MEET=1_U_VSDTM_U_U_VISIT_U_IEN,QFL=1
- .. I $G(BQIAND)'="" D
- ... I BQIAND,MEET Q
- ... I 'BQIAND,MEET S MEET=0
- ;
- I $G(EXEC)'="" X EXEC
- ;
- XIT Q MEET
- ;
- BLD(TRMT,REF,CEXEC) ;EP
- K CEXEC
- NEW BN,IEN,DATA
- S BN=0
- F S BN=$O(^BQI(90508.5,TRMT,5,"B",BN)) Q:'BN D
- . S IEN=0
- . F S IEN=$O(^BQI(90508.5,TRMT,5,"B",BN,IEN)) Q:'IEN D
- .. S DATA=^BQI(90508.5,TRMT,5,IEN,0)
- .. ; Exclude the SEARCH ORDER field and only take pieces 2-7
- .. S @REF@(BN)=$P(DATA,U,2,7)
- .. S CEXEC(BN)=$G(^BQI(90508.5,TRMT,5,IEN,1))
- Q
- ;
- PRS ; Parse description
- S NDESC=$P(NDESC,"|",1)_$G(PARMS($P(NDESC,"|",2)))_$P(NDESC,"|",3,99)
- S PDESC=NDESC
- Q
- BQITRPPT ;PRXM/HC/ALA-Treatment Prompt ; 24 Apr 2007 11:47 AM
- +1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
- +2 ;
- +3 QUIT
- +4 ;
- FND(BQTRMT,BQGLOB,BQDFN,BQRM) ;EP
- +1 ;
- +2 ; Input Parameters
- +3 ; BQTRMT - Treatment Prompt
- +4 ; BQGLOB - Reference to store data
- +5 ; BQDFN - Patient IEN
- +6 ; BQRM - Remarks array
- +7 ; Output Parameter
- +8 ; MEET - If zero, didn't meet the criteria
- +9 ; If one, did meet the criteria
- +10 ;
- +11 NEW BQREF,CEXE,MEET,N,TAX,NIT,TMFRAME,FREF,ABS,CONT,GREF,TREF,IEN,TIEN,EXEC
- +12 NEW CEXEC,BQIAND,BQIOR
- +13 ;S BQREF="BQIRY" K @BQREF
- +14 ;D BLD(BQTRMT,BQREF,.CEXEC)
- +15 ;
- +16 ; Find if there is a special executable for the treatment prompt
- +17 SET EXEC=$GET(^BQI(90508.5,BQTRMT,2))
- +18 IF $GET(EXEC)'=""
- XECUTE EXEC
- +19 ; EXEC should always return RESULT
- +20 ;
- +21 ; update remarks if patient passed all the checks
- +22 IF $PIECE(RESULT,U,1)=1
- Begin DoDot:1
- +23 KILL PARMS
- +24 ; Set the parameter values returned from API
- +25 FOR BN=3:1:$LENGTH(RESULT,U)
- SET PARMS(BN-2)=$PIECE(RESULT,U,BN)
- +26 SET BN=0
- +27 FOR
- SET BN=$ORDER(BQRM(BN))
- IF BN=""
- QUIT
- Begin DoDot:2
- +28 IF BQRM(BN)'["|"
- QUIT
- +29 ; Apply parameters into remarks
- +30 SET NDESC=BQRM(BN)
- +31 FOR
- IF '$FIND(NDESC,"|")
- QUIT
- DO PRS
- +32 SET BQRM(BN)=PDESC
- End DoDot:2
- End DoDot:1
- +33 QUIT RESULT
- +34 ;
- +35 SET MEET=1
- +36 ;
- +37 ; If taxonomy checks are used to determine whether patient meets criteria or not
- +38 IF $DATA(@BQREF)
- Begin DoDot:1
- +39 SET N=0
- FOR
- SET N=$ORDER(@BQREF@(N))
- IF 'N
- QUIT
- Begin DoDot:2
- +40 SET TAX=$PIECE(@BQREF@(N),U,1)
- SET NIT=$PIECE(@BQREF@(N),U,2)
- +41 SET TMFRAME=$PIECE(@BQREF@(N),U,3)
- SET FREF=$PIECE(@BQREF@(N),U,4)
- +42 IF TMFRAME'=""
- SET EDATE=$$DATE^BQIUL1(TMFRAME)
- SET BDATE=DT
- +43 IF TMFRAME=""
- SET EDATE=$$DATE^BQIUL1("T-12M")
- SET BDATE=DT
- +44 SET ABS=$PIECE(@BQREF@(N),U,5)
- SET CONT=+$PIECE(@BQREF@(N),U,6)
- +45 ;
- +46 ; Check for a contraindication executable
- +47 SET CEXE=$GET(CEXEC(N))
- +48 IF $GET(CEXE)'=""
- Begin DoDot:3
- +49 SET DFN=BQDFN
- +50 ;I $G(DFN)="" S DFN=BQDFN
- +51 XECUTE CEXE
- +52 ;
- +53 ; If absence/presence is defined
- +54 IF ABS'=""
- Begin DoDot:4
- +55 IF 'X
- IF 'ABS
- SET MEET=1
- QUIT
- +56 IF 'X
- IF ABS
- SET MEET=0
- QUIT
- +57 IF X
- IF 'ABS
- SET MEET=0
- QUIT
- +58 IF X
- IF ABS
- SET MEET=1
- End DoDot:4
- +59 ; If absence/presence is not defined
- +60 IF ABS=""
- Begin DoDot:4
- +61 IF X
- SET MEET=1
- QUIT
- +62 IF 'X
- SET MEET=0
- End DoDot:4
- +63 ;I MEET,X,CONT S MEET=0
- +64 ;I MEET,X,'CONT S MEET=1
- +65 ;I MEET,'X,'CONT S MEET=0
- +66 ; If met criteria but also met contraindication
- +67 IF MEET
- IF CONT
- SET MEET=0
- +68 IF MEET
- IF 'CONT
- SET MEET=1
- +69 IF 'MEET
- IF CONT
- SET MEET=1
- +70 IF 'MEET
- IF 'CONT
- SET MEET=0
- +71 ;
- +72 IF 'MEET
- QUIT
- +73 ; update remarks if patient passed all the checks
- +74 KILL PARMS
- +75 FOR BN=2:1:$LENGTH(X,U)
- SET PARMS(BN-1)=$PIECE(X,U,BN)
- +76 SET BN=0
- +77 FOR
- SET BN=$ORDER(BQRM(BN))
- IF BN=""
- QUIT
- Begin DoDot:4
- +78 IF BQRM(BN)'["|"
- QUIT
- +79 SET NDESC=BQRM(BN)
- +80 FOR
- IF '$FIND(NDESC,"|")
- QUIT
- DO PRS
- +81 ;I PDESC["~"
- +82 SET BQRM(BN)=PDESC
- End DoDot:4
- End DoDot:3
- QUIT
- +83 ;
- +84 SET GREF=$$ROOT^DILFD(FREF,"",1)
- SET TREF=$NAME(^TMP("BQITAX",UID))
- +85 ; Build the taxonomy reference
- +86 KILL @TREF
- +87 IF TAX=""
- QUIT
- +88 DO BLD^BQITUTL(TAX,TREF)
- +89 SET IEN=""
- SET QFL=0
- +90 FOR
- SET IEN=$ORDER(@GREF@("AC",BQDFN,IEN),-1)
- IF IEN=""
- QUIT
- Begin DoDot:3
- +91 SET TIEN=$$GET1^DIQ(FREF,IEN_",",.01,"I")
- IF TIEN=""
- QUIT
- +92 IF '$DATA(@TREF@(TIEN))
- QUIT
- +93 SET VISIT=$$GET1^DIQ(FREF,IEN_",",.03,"I")
- IF VISIT=""
- QUIT
- +94 IF $$GET1^DIQ(9000010,VISIT_",",.11,"I")=1
- QUIT
- +95 SET VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I")\1
- IF VSDTM=0
- QUIT
- +96 IF $GET(TMFRAME)'=""
- IF VSDTM<EDATE
- QUIT
- +97 ; If absence of data, then it did not meet the criteria
- +98 IF ABS=0
- SET MEET=0
- SET QFL=1
- QUIT
- +99 SET MEET=1_U_VSDTM_U_U_VISIT_U_IEN
- SET QFL=1
- End DoDot:3
- IF QFL
- QUIT
- +100 IF $GET(BQIAND)'=""
- Begin DoDot:3
- +101 IF BQIAND
- IF MEET
- QUIT
- +102 IF 'BQIAND
- IF MEET
- SET MEET=0
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +103 ;
- +104 IF $GET(EXEC)'=""
- XECUTE EXEC
- +105 ;
- XIT QUIT MEET
- +1 ;
- BLD(TRMT,REF,CEXEC) ;EP
- +1 KILL CEXEC
- +2 NEW BN,IEN,DATA
- +3 SET BN=0
- +4 FOR
- SET BN=$ORDER(^BQI(90508.5,TRMT,5,"B",BN))
- IF 'BN
- QUIT
- Begin DoDot:1
- +5 SET IEN=0
- +6 FOR
- SET IEN=$ORDER(^BQI(90508.5,TRMT,5,"B",BN,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:2
- +7 SET DATA=^BQI(90508.5,TRMT,5,IEN,0)
- +8 ; Exclude the SEARCH ORDER field and only take pieces 2-7
- +9 SET @REF@(BN)=$PIECE(DATA,U,2,7)
- +10 SET CEXEC(BN)=$GET(^BQI(90508.5,TRMT,5,IEN,1))
- End DoDot:2
- End DoDot:1
- +11 QUIT
- +12 ;
- PRS ; Parse description
- +1 SET NDESC=$PIECE(NDESC,"|",1)_$GET(PARMS($PIECE(NDESC,"|",2)))_$PIECE(NDESC,"|",3,99)
- +2 SET PDESC=NDESC
- +3 QUIT
