- BWUTL6 ;IHS/ANMC/MWR - UTIL: TEXT VALS, DEF PRINT DATE;15-Feb-2003 22:15;PLS
- ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
- ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- ;; UTILITY: TEXT FOR PROVIDER, PROCEDURE, HOSP LOC, INSTIT, & ECC.
- ;; PROC SPECIAL VALUE (PAP, MAM, COLP). COMPUTE DEFAULT PRINT DATE.
- ;
- ;
- PROV() ;EP
- ;---> RETURN TEXT OF PROVIDER'S NAME.
- ;---> REQUIRED VARIABLE: X=IEN IN NEW PERSON FILE #200.
- Q:'$D(X) ""
- Q:'X "UNKNOWN"
- Q:'$D(^VA(200,X,0)) "UNKNOWN POINTER"
- Q $P(^VA(200,X,0),U)
- ;
- ;
- PCDNAM() ;EP
- ;---> RETURN TEXT OF PROCEDURE TYPE.
- ;---> REQUIRED VARIABLE: X=IEN IN BW PROCEDURE TYPE FILE #9002086.2.
- Q:'$D(X) ""
- Q:'X "UNKNOWN"
- Q:'$D(^BWPN(X,0)) "UNKNOWN POINTER"
- Q $P(^BWPN(X,0),U)
- ;
- HOSPLC() ;EP
- ;---> RETURN TEXT OF HOSPITAL LOCATION NAME.
- ;---> REQUIRED VARIABLE: X=IEN IN HOSPITAL LOCATION FILE #44.
- Q:'$D(X) ""
- Q:'X "UNKNOWN"
- Q:'$D(^SC(X,0)) "UNKNOWN POINTER"
- Q $P(^SC(X,0),U)
- ;
- INSTIT() ;EP
- ;---> RETURN IEN OF INSTITUTION (FACILITY) FILE 4, FOR THIS HOSPITAL
- ;---> LOCATION ENTRY IN HOSPITAL LOCATION FILE 44.
- ;---> ALSO CONCATENATE "`" TO THE FRONT OF IEN FOR USE IN DR STRINGS.
- Q:'$D(X) ""
- Q:X="" ""
- Q:'$D(^SC(X,0)) ""
- Q:$P(^SC(X,0),U,4)']"" ""
- Q "`"_$P(^SC(X,0),U,4)
- ;
- INSTTX(FACILITY) ;EP
- ;---> RETURN TEXT OF INSTITUTION (FACILITY) NAME.
- ;---> REQUIRED VARIABLE: X=IEN IN INSTITUTION FILE #4.
- Q:'$G(FACILITY) ""
- Q:'$D(^DIC(4,FACILITY,0)) "UNKNOWN POINTER"
- Q $P(^DIC(4,FACILITY,0),U)
- ;
- ECCDYS() ;EP
- ;---> RETURN TEXT FROM SET OF CODES FOR ECC DYSPLASIA, FIELD .25,
- ;---> OF PROCEDURE FILE 9002086.1.
- ;---> REQUIRED VARIABLE: X=CODE FOR TEXT OF ECC DYSPLASIA.
- Q:'$D(X) ""
- Q:X="" ""
- Q:'$D(^DD(9002086.1,.25,0)) "^DD MISSING"
- Q $P($P(^DD(9002086.1,.25,0),X_":",2),";")
- ;
- PNOCX(IEN) ;EP
- ;---> RETURN 1 IF THIS PROCEDURE IS NOT ANY TYPE OF CERVICAL TX.
- Q:'$G(IEN) 1
- Q:'$D(^BWPN(IEN,0)) 1
- Q:$$PMAM(IEN) 1
- Q:IEN=27 1 Q:IEN=29 1 Q:IEN=30 1 Q:IEN=31 1 Q:IEN=32 1
- Q:IEN=33 1 Q:IEN=34 1 Q:IEN=35 1
- Q 0
- ;
- ;
- PMAM(IEN) ;EP
- ;---> RETURN 1 IF THIS PROCEDURE IS ANY TYPE OF MAMMOGRAM, RETURN 0
- ;---> IF NOT.
- ;---> REQUIRED VARIABLE: IEN=IEN IN PROCEDURE TYPE FILE #9002086.2.
- ;---> 25, 26, AND 27 ARE IENS OF MAMS IN ^BWPN(.
- Q:'$G(IEN) 0
- Q:IEN=25 1 Q:IEN=26 1 Q:IEN=28 1
- Q 0
- ;
- ;
- PRTDATE ;EP
- ;---> CALL BY BW NOTIF-EDITBLK-1 TO COMPUTE AND STUFF DATE NOTIFICATION
- ;---> LETTER WILL BE PRINTED, "Print Date" FIELD. CALLED FROM
- ;---> "TYPE OF NOTIFICATION" FIELD ORDER, "POST ACTION ON CHANGE".
- ;--->
- ;---> IF THE "TYPE OF NOTIFICATION" IS PRINTABLE (LETTER), AS STORED
- ;---> IN #.02 FIELD OF FILE #9002086.403, THIS COMPUTES PRINT DATE AND
- ;---> STUFFS A DEFAULT "COMPLETE BY DATE" (FIELD #.13) AS WELL.
- ;---> "PRINT DATE" WILL BE CX/BR NEED DUE DATE - SITE PARAMETER, AS
- ;---> STORED IN #.06 FIELD OF FILE #9002086.02, OR -30 DAYS IF
- ;---> PARAMETER NOT SET. (SEE PRTDAT^BWUTL2-ABOVE.)
- ;---> "COMPLETE BY DATE" WILL BE "PRINT DATE"+30. SEE NDELQ1^BWUTL4.
- ;--->
- ;---> IF THE "TYPE OF NOTIFICATION" IS NOT PRINTABLE (PHONE), THIS
- ;---> SETS "PRINT DATE"="" AND RECOMPUTES "COMPLETE BY DATE" BASED ON
- ;---> DATE NOTIFICATION WAS OPENED (FIELD #.02) +30 DAYS.
- ;
- ;---> (NOTE: FOR UNIFORMITY, EXECUTABLE DEFAULT FOR "PRINT DATE"
- ;---> CALLS THIS CODE TO SET ITS STORED VALUE, THEN SETS ITS DEFAULT
- ;---> EQUAL TO ITS STORED VALUE.)
- ;--->
- ;---> REQUIRED VARIABLES: BWDFN=IEN OF PATIENT
- ;---> DUZ(2)=SITE
- ;---> BWTYPE=IEN TYPE OF NOTIFICATION (LETTER, ETC)
- ;---> BWPURP=IEN PURPOSE OF NOTIFICATION
- ;
- N BWTYPE,BWPURP,X,Y
- S BWTYPE=$$GET^DDSVAL(DIE,DA,.03)
- I 'BWTYPE D PUT^DDSVAL(DIE,DA,.11,"") Q
- ;---> IF NOT PRINTABLE, SET PRINT DATE="".
- I '$P(^BWNOTT(BWTYPE,0),U,2) D Q
- .D PUT^DDSVAL(DIE,DA,.11,"")
- .S X=$$NDELQ^BWUTL4 D PUT^DDSVAL(DIE,DA,.13,X)
- S BWPURP=$$GET^DDSVAL(DIE,DA,.04)
- ;---> COMPUTE AND STUFF PRINT DATE.
- D PRTDAT(BWDFN,DUZ(2),BWTYPE,BWPURP,.X)
- D PUT^DDSVAL(DIE,DA,.11,X)
- ;---> COMPUTE AND STUFF COMPLETE BY DATE.
- S X=$$NDELQ1^BWUTL4 D PUT^DDSVAL(DIE,DA,.13,X)
- Q
- ;
- ;
- PRTDAT(DFN,DUZ2,TYPE,PURP,DATE) ;EP
- ;---> YIELD PATIENT'S LETTER PRINT DATE, BASED ON CX/BR NEED.
- ;---> DUE DATE MINUS SITE PARAMETER (OR 30 DAYS, IF NOT SET).
- ;---> TYPE OF NOTIFICATION MUST BE "PRINTABLE" (#.02 OF #9002086.403).
- ;---> REQUIRED VARIABLES: DFN=IEN OF PATIENT
- ;---> DUZ2=DUZ(2)
- ;---> TYPE=IEN TYPE OF NOTIFICATION
- ;---> PURP=IEN PURPOSE OF NOTIFICATION
- ;---> RETURNS VARIABLES: DATE=DEFAULT DATE LETTER SHOULD BE PRINTED
- ;
- N P,Q,X,X1,X2
- S DATE=""
- Q:'TYPE!('PURP)
- ;---> QUIT IF THIS "TYPE OF NOTIFICATION" IS NOT "PRINTABLE" (PIECE 2).
- Q:'$P(^BWNOTT(TYPE,0),U,2)
- S X2=$P(^BWSITE(DUZ2,0),U,6)
- S X2=$S(X2:-X2,1:-30)
- Q:'$D(^BWP(DFN,0))
- ;---> IF THIS PURPOSE IS A RESULT LETTER, SET PRINT DATE=TODAY, QUIT.
- Q:'$D(^BWNOTP(PURP,0))
- I $P(^BWNOTP(PURP,0),U,6) S DATE=DT Q
- ;---> IF THIS IS NOT ASSOCIATED WITH BR/CX NEEDS, QUIT WITH DATE="".
- Q:$P(^BWNOTP(PURP,0),U,5)=""
- S:$P(^BWNOTP(PURP,0),U,5)="CX" P=11,Q=12
- S:$P(^BWNOTP(PURP,0),U,5)="BR" P=18,Q=19
- ;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED ENTERED.
- Q:'$P(^BWP(DFN,0),U,P)
- ;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED DUE DATE.
- S X=$P(^BWP(DFN,0),U,Q) Q:'X
- S:'$E(X,7) $E(X,7)=1
- S X1=X D C^%DTC
- S DATE=X
- Q
- BWUTL6 ;IHS/ANMC/MWR - UTIL: TEXT VALS, DEF PRINT DATE;15-Feb-2003 22:15;PLS
- +1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
- +2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- +3 ;; UTILITY: TEXT FOR PROVIDER, PROCEDURE, HOSP LOC, INSTIT, & ECC.
- +4 ;; PROC SPECIAL VALUE (PAP, MAM, COLP). COMPUTE DEFAULT PRINT DATE.
- +5 ;
- +6 ;
- PROV() ;EP
- +1 ;---> RETURN TEXT OF PROVIDER'S NAME.
- +2 ;---> REQUIRED VARIABLE: X=IEN IN NEW PERSON FILE #200.
- +3 IF '$DATA(X)
- QUIT ""
- +4 IF 'X
- QUIT "UNKNOWN"
- +5 IF '$DATA(^VA(200,X,0))
- QUIT "UNKNOWN POINTER"
- +6 QUIT $PIECE(^VA(200,X,0),U)
- +7 ;
- +8 ;
- PCDNAM() ;EP
- +1 ;---> RETURN TEXT OF PROCEDURE TYPE.
- +2 ;---> REQUIRED VARIABLE: X=IEN IN BW PROCEDURE TYPE FILE #9002086.2.
- +3 IF '$DATA(X)
- QUIT ""
- +4 IF 'X
- QUIT "UNKNOWN"
- +5 IF '$DATA(^BWPN(X,0))
- QUIT "UNKNOWN POINTER"
- +6 QUIT $PIECE(^BWPN(X,0),U)
- +7 ;
- HOSPLC() ;EP
- +1 ;---> RETURN TEXT OF HOSPITAL LOCATION NAME.
- +2 ;---> REQUIRED VARIABLE: X=IEN IN HOSPITAL LOCATION FILE #44.
- +3 IF '$DATA(X)
- QUIT ""
- +4 IF 'X
- QUIT "UNKNOWN"
- +5 IF '$DATA(^SC(X,0))
- QUIT "UNKNOWN POINTER"
- +6 QUIT $PIECE(^SC(X,0),U)
- +7 ;
- INSTIT() ;EP
- +1 ;---> RETURN IEN OF INSTITUTION (FACILITY) FILE 4, FOR THIS HOSPITAL
- +2 ;---> LOCATION ENTRY IN HOSPITAL LOCATION FILE 44.
- +3 ;---> ALSO CONCATENATE "`" TO THE FRONT OF IEN FOR USE IN DR STRINGS.
- +4 IF '$DATA(X)
- QUIT ""
- +5 IF X=""
- QUIT ""
- +6 IF '$DATA(^SC(X,0))
- QUIT ""
- +7 IF $PIECE(^SC(X,0),U,4)']""
- QUIT ""
- +8 QUIT "`"_$PIECE(^SC(X,0),U,4)
- +9 ;
- INSTTX(FACILITY) ;EP
- +1 ;---> RETURN TEXT OF INSTITUTION (FACILITY) NAME.
- +2 ;---> REQUIRED VARIABLE: X=IEN IN INSTITUTION FILE #4.
- +3 IF '$GET(FACILITY)
- QUIT ""
- +4 IF '$DATA(^DIC(4,FACILITY,0))
- QUIT "UNKNOWN POINTER"
- +5 QUIT $PIECE(^DIC(4,FACILITY,0),U)
- +6 ;
- ECCDYS() ;EP
- +1 ;---> RETURN TEXT FROM SET OF CODES FOR ECC DYSPLASIA, FIELD .25,
- +2 ;---> OF PROCEDURE FILE 9002086.1.
- +3 ;---> REQUIRED VARIABLE: X=CODE FOR TEXT OF ECC DYSPLASIA.
- +4 IF '$DATA(X)
- QUIT ""
- +5 IF X=""
- QUIT ""
- +6 IF '$DATA(^DD(9002086.1,.25,0))
- QUIT "^DD MISSING"
- +7 QUIT $PIECE($PIECE(^DD(9002086.1,.25,0),X_":",2),";")
- +8 ;
- PNOCX(IEN) ;EP
- +1 ;---> RETURN 1 IF THIS PROCEDURE IS NOT ANY TYPE OF CERVICAL TX.
- +2 IF '$GET(IEN)
- QUIT 1
- +3 IF '$DATA(^BWPN(IEN,0))
- QUIT 1
- +4 IF $$PMAM(IEN)
- QUIT 1
- +5 IF IEN=27
- QUIT 1
- IF IEN=29
- QUIT 1
- IF IEN=30
- QUIT 1
- IF IEN=31
- QUIT 1
- IF IEN=32
- QUIT 1
- +6 IF IEN=33
- QUIT 1
- IF IEN=34
- QUIT 1
- IF IEN=35
- QUIT 1
- +7 QUIT 0
- +8 ;
- +9 ;
- PMAM(IEN) ;EP
- +1 ;---> RETURN 1 IF THIS PROCEDURE IS ANY TYPE OF MAMMOGRAM, RETURN 0
- +2 ;---> IF NOT.
- +3 ;---> REQUIRED VARIABLE: IEN=IEN IN PROCEDURE TYPE FILE #9002086.2.
- +4 ;---> 25, 26, AND 27 ARE IENS OF MAMS IN ^BWPN(.
- +5 IF '$GET(IEN)
- QUIT 0
- +6 IF IEN=25
- QUIT 1
- IF IEN=26
- QUIT 1
- IF IEN=28
- QUIT 1
- +7 QUIT 0
- +8 ;
- +9 ;
- PRTDATE ;EP
- +1 ;---> CALL BY BW NOTIF-EDITBLK-1 TO COMPUTE AND STUFF DATE NOTIFICATION
- +2 ;---> LETTER WILL BE PRINTED, "Print Date" FIELD. CALLED FROM
- +3 ;---> "TYPE OF NOTIFICATION" FIELD ORDER, "POST ACTION ON CHANGE".
- +4 ;--->
- +5 ;---> IF THE "TYPE OF NOTIFICATION" IS PRINTABLE (LETTER), AS STORED
- +6 ;---> IN #.02 FIELD OF FILE #9002086.403, THIS COMPUTES PRINT DATE AND
- +7 ;---> STUFFS A DEFAULT "COMPLETE BY DATE" (FIELD #.13) AS WELL.
- +8 ;---> "PRINT DATE" WILL BE CX/BR NEED DUE DATE - SITE PARAMETER, AS
- +9 ;---> STORED IN #.06 FIELD OF FILE #9002086.02, OR -30 DAYS IF
- +10 ;---> PARAMETER NOT SET. (SEE PRTDAT^BWUTL2-ABOVE.)
- +11 ;---> "COMPLETE BY DATE" WILL BE "PRINT DATE"+30. SEE NDELQ1^BWUTL4.
- +12 ;--->
- +13 ;---> IF THE "TYPE OF NOTIFICATION" IS NOT PRINTABLE (PHONE), THIS
- +14 ;---> SETS "PRINT DATE"="" AND RECOMPUTES "COMPLETE BY DATE" BASED ON
- +15 ;---> DATE NOTIFICATION WAS OPENED (FIELD #.02) +30 DAYS.
- +16 ;
- +17 ;---> (NOTE: FOR UNIFORMITY, EXECUTABLE DEFAULT FOR "PRINT DATE"
- +18 ;---> CALLS THIS CODE TO SET ITS STORED VALUE, THEN SETS ITS DEFAULT
- +19 ;---> EQUAL TO ITS STORED VALUE.)
- +20 ;--->
- +21 ;---> REQUIRED VARIABLES: BWDFN=IEN OF PATIENT
- +22 ;---> DUZ(2)=SITE
- +23 ;---> BWTYPE=IEN TYPE OF NOTIFICATION (LETTER, ETC)
- +24 ;---> BWPURP=IEN PURPOSE OF NOTIFICATION
- +25 ;
- +26 NEW BWTYPE,BWPURP,X,Y
- +27 SET BWTYPE=$$GET^DDSVAL(DIE,DA,.03)
- +28 IF 'BWTYPE
- DO PUT^DDSVAL(DIE,DA,.11,"")
- QUIT
- +29 ;---> IF NOT PRINTABLE, SET PRINT DATE="".
- +30 IF '$PIECE(^BWNOTT(BWTYPE,0),U,2)
- Begin DoDot:1
- +31 DO PUT^DDSVAL(DIE,DA,.11,"")
- +32 SET X=$$NDELQ^BWUTL4
- DO PUT^DDSVAL(DIE,DA,.13,X)
- End DoDot:1
- QUIT
- +33 SET BWPURP=$$GET^DDSVAL(DIE,DA,.04)
- +34 ;---> COMPUTE AND STUFF PRINT DATE.
- +35 DO PRTDAT(BWDFN,DUZ(2),BWTYPE,BWPURP,.X)
- +36 DO PUT^DDSVAL(DIE,DA,.11,X)
- +37 ;---> COMPUTE AND STUFF COMPLETE BY DATE.
- +38 SET X=$$NDELQ1^BWUTL4
- DO PUT^DDSVAL(DIE,DA,.13,X)
- +39 QUIT
- +40 ;
- +41 ;
- PRTDAT(DFN,DUZ2,TYPE,PURP,DATE) ;EP
- +1 ;---> YIELD PATIENT'S LETTER PRINT DATE, BASED ON CX/BR NEED.
- +2 ;---> DUE DATE MINUS SITE PARAMETER (OR 30 DAYS, IF NOT SET).
- +3 ;---> TYPE OF NOTIFICATION MUST BE "PRINTABLE" (#.02 OF #9002086.403).
- +4 ;---> REQUIRED VARIABLES: DFN=IEN OF PATIENT
- +5 ;---> DUZ2=DUZ(2)
- +6 ;---> TYPE=IEN TYPE OF NOTIFICATION
- +7 ;---> PURP=IEN PURPOSE OF NOTIFICATION
- +8 ;---> RETURNS VARIABLES: DATE=DEFAULT DATE LETTER SHOULD BE PRINTED
- +9 ;
- +10 NEW P,Q,X,X1,X2
- +11 SET DATE=""
- +12 IF 'TYPE!('PURP)
- QUIT
- +13 ;---> QUIT IF THIS "TYPE OF NOTIFICATION" IS NOT "PRINTABLE" (PIECE 2).
- +14 IF '$PIECE(^BWNOTT(TYPE,0),U,2)
- QUIT
- +15 SET X2=$PIECE(^BWSITE(DUZ2,0),U,6)
- +16 SET X2=$SELECT(X2:-X2,1:-30)
- +17 IF '$DATA(^BWP(DFN,0))
- QUIT
- +18 ;---> IF THIS PURPOSE IS A RESULT LETTER, SET PRINT DATE=TODAY, QUIT.
- +19 IF '$DATA(^BWNOTP(PURP,0))
- QUIT
- +20 IF $PIECE(^BWNOTP(PURP,0),U,6)
- SET DATE=DT
- QUIT
- +21 ;---> IF THIS IS NOT ASSOCIATED WITH BR/CX NEEDS, QUIT WITH DATE="".
- +22 IF $PIECE(^BWNOTP(PURP,0),U,5)=""
- QUIT
- +23 IF $PIECE(^BWNOTP(PURP,0),U,5)="CX"
- SET P=11
- SET Q=12
- +24 IF $PIECE(^BWNOTP(PURP,0),U,5)="BR"
- SET P=18
- SET Q=19
- +25 ;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED ENTERED.
- +26 IF '$PIECE(^BWP(DFN,0),U,P)
- QUIT
- +27 ;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED DUE DATE.
- +28 SET X=$PIECE(^BWP(DFN,0),U,Q)
- IF 'X
- QUIT
- +29 IF '$EXTRACT(X,7)
- SET $EXTRACT(X,7)=1
- +30 SET X1=X
- DO C^%DTC
- +31 SET DATE=X
- +32 QUIT