WVUTL6 ;HCIOFO/FT,JR-UTIL: TEXT VALS, DEF PRINT DATE; ;10/11/99 14:03
;;1.0;WOMEN'S HEALTH;**3,7**;Sep 30, 1998
;; Original routine created by IHS/ANMC/MWR
;;* 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.
N WVNAME
Q:'$D(X) ""
Q:'X "UNKNOWN"
S WVNAME=$$GET1^DIQ(200,X,.01,"E")
Q $S(WVNAME'="":WVNAME,1:"UNKNOWN POINTER")
;
;
PCDNAM() ;EP
;---> RETURN TEXT OF PROCEDURE TYPE.
;---> REQUIRED VARIABLE: X=IEN IN WV PROCEDURE TYPE FILE #790.2.
Q:'$D(X) ""
Q:'X "UNKNOWN"
Q:'$D(^WV(790.2,X,0)) "UNKNOWN POINTER"
Q $P(^WV(790.2,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) ""
N WVDIC4
S WVDIC4=$$GET1^DIQ(4,FACILITY,.01,"E")
Q $S(WVDIC4]"":WVDIC4,1:"UNKNOWN POINTER")
;
ECCDYS() ;EP
;---> RETURN TEXT FROM SET OF CODES FOR ECC DYSPLASIA, FIELD .25,
;---> OF PROCEDURE FILE 790.1.
;---> REQUIRED VARIABLE: X=CODE FOR TEXT OF ECC DYSPLASIA.
Q:'$D(X) ""
Q:X="" ""
I '$$VFIELD^DILFD(790.1,.25) Q "^DD MISSING"
Q $$EXTERNAL^DILFD(790.1,.25,"",X)
;
PNOCX(IEN) ;EP
;---> RETURN 1 IF THIS PROCEDURE IS NOT ANY TYPE OF CERVICAL TX.
Q:'$G(IEN) 1
Q:'$D(^WV(790.2,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 #790.2.
;---> 25, 26, AND 27 ARE IENS OF MAMS IN ^WV(790.2,.
Q:'$G(IEN) 0
Q:IEN=25 1 Q:IEN=26 1 Q:IEN=28 1
Q 0
;
;
PRTDATE ;EP
;---> CALL BY WV 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 #790.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 #790.02, OR -30 DAYS IF
;---> PARAMETER NOT SET. (SEE PRTDAT^WVUTL2-ABOVE.)
;---> "COMPLETE BY DATE" WILL BE "PRINT DATE"+30. SEE NDELQ1^WVUTL4.
;--->
;---> 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: WVDFN=IEN OF PATIENT
;---> DUZ(2)=SITE
;---> WVTYPE=IEN TYPE OF NOTIFICATION (LETTER, ETC)
;---> WVPURP=IEN PURPOSE OF NOTIFICATION
;
N WVTYPE,WVPURP,X,Y
S WVTYPE=$$GET^DDSVAL(DIE,DA,.03)
I 'WVTYPE D PUT^DDSVAL(DIE,DA,.11,"") Q
;---> IF NOT PRINTABLE, SET PRINT DATE="".
I '$P(^WV(790.403,WVTYPE,0),U,2) D Q
.D PUT^DDSVAL(DIE,DA,.11,"")
.S X=$$NDELQ^WVUTL4 D PUT^DDSVAL(DIE,DA,.13,X)
S WVPURP=$$GET^DDSVAL(DIE,DA,.04)
;---> COMPUTE AND STUFF PRINT DATE.
D PRTDAT(WVDFN,DUZ(2),WVTYPE,WVPURP,.X)
D PUT^DDSVAL(DIE,DA,.11,X)
;---> COMPUTE AND STUFF COMPLETE BY DATE.
S X=$$NDELQ1^WVUTL4 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 #790.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(^WV(790.403,TYPE,0),U,2)
S X2=$P($G(^WV(790.02,DUZ2,0)),U,6)
S X2=$S(X2:-X2,1:-30)
Q:'$D(^WV(790,DFN,0))
;---> IF THIS PURPOSE IS A RESULT LETTER, SET PRINT DATE=TODAY, QUIT.
Q:'$D(^WV(790.404,PURP,0))
I $P(^WV(790.404,PURP,0),U,6) S DATE=DT Q
;---> IF THIS IS NOT ASSOCIATED WITH BR/CX NEEDS, QUIT WITH DATE="".
Q:$P(^WV(790.404,PURP,0),U,5)=""
S:$P(^WV(790.404,PURP,0),U,5)="CX" P=11,Q=12
S:$P(^WV(790.404,PURP,0),U,5)="BR" P=18,Q=19
;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED ENTERED.
Q:'$P(^WV(790,DFN,0),U,P)
;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED DUE DATE.
S X=$P(^WV(790,DFN,0),U,Q) Q:'X
S:'$E(X,7) $E(X,7)=1
S X1=X D C^%DTC
S DATE=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVUTL6 5619 printed Dec 13, 2024@02:48:15 Page 2
WVUTL6 ;HCIOFO/FT,JR-UTIL: TEXT VALS, DEF PRINT DATE; ;10/11/99 14:03
+1 ;;1.0;WOMEN'S HEALTH;**3,7**;Sep 30, 1998
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; UTILITY: TEXT FOR PROVIDER, PROCEDURE, HOSP LOC, INSTIT, & ECC.
+5 ;; PROC SPECIAL VALUE (PAP, MAM, COLP). COMPUTE DEFAULT PRINT DATE.
+6 ;
+7 ;
PROV() ;EP
+1 ;---> RETURN TEXT OF PROVIDER'S NAME.
+2 ;---> REQUIRED VARIABLE: X=IEN IN NEW PERSON FILE #200.
+3 NEW WVNAME
+4 if '$DATA(X)
QUIT ""
+5 if 'X
QUIT "UNKNOWN"
+6 SET WVNAME=$$GET1^DIQ(200,X,.01,"E")
+7 QUIT $SELECT(WVNAME'="":WVNAME,1:"UNKNOWN POINTER")
+8 ;
+9 ;
PCDNAM() ;EP
+1 ;---> RETURN TEXT OF PROCEDURE TYPE.
+2 ;---> REQUIRED VARIABLE: X=IEN IN WV PROCEDURE TYPE FILE #790.2.
+3 if '$DATA(X)
QUIT ""
+4 if 'X
QUIT "UNKNOWN"
+5 if '$DATA(^WV(790.2,X,0))
QUIT "UNKNOWN POINTER"
+6 QUIT $PIECE(^WV(790.2,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 NEW WVDIC4
+5 SET WVDIC4=$$GET1^DIQ(4,FACILITY,.01,"E")
+6 QUIT $SELECT(WVDIC4]"":WVDIC4,1:"UNKNOWN POINTER")
+7 ;
ECCDYS() ;EP
+1 ;---> RETURN TEXT FROM SET OF CODES FOR ECC DYSPLASIA, FIELD .25,
+2 ;---> OF PROCEDURE FILE 790.1.
+3 ;---> REQUIRED VARIABLE: X=CODE FOR TEXT OF ECC DYSPLASIA.
+4 if '$DATA(X)
QUIT ""
+5 if X=""
QUIT ""
+6 IF '$$VFIELD^DILFD(790.1,.25)
QUIT "^DD MISSING"
+7 QUIT $$EXTERNAL^DILFD(790.1,.25,"",X)
+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(^WV(790.2,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 #790.2.
+4 ;---> 25, 26, AND 27 ARE IENS OF MAMS IN ^WV(790.2,.
+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 WV 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 #790.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 #790.02, OR -30 DAYS IF
+10 ;---> PARAMETER NOT SET. (SEE PRTDAT^WVUTL2-ABOVE.)
+11 ;---> "COMPLETE BY DATE" WILL BE "PRINT DATE"+30. SEE NDELQ1^WVUTL4.
+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: WVDFN=IEN OF PATIENT
+22 ;---> DUZ(2)=SITE
+23 ;---> WVTYPE=IEN TYPE OF NOTIFICATION (LETTER, ETC)
+24 ;---> WVPURP=IEN PURPOSE OF NOTIFICATION
+25 ;
+26 NEW WVTYPE,WVPURP,X,Y
+27 SET WVTYPE=$$GET^DDSVAL(DIE,DA,.03)
+28 IF 'WVTYPE
DO PUT^DDSVAL(DIE,DA,.11,"")
QUIT
+29 ;---> IF NOT PRINTABLE, SET PRINT DATE="".
+30 IF '$PIECE(^WV(790.403,WVTYPE,0),U,2)
Begin DoDot:1
+31 DO PUT^DDSVAL(DIE,DA,.11,"")
+32 SET X=$$NDELQ^WVUTL4
DO PUT^DDSVAL(DIE,DA,.13,X)
End DoDot:1
QUIT
+33 SET WVPURP=$$GET^DDSVAL(DIE,DA,.04)
+34 ;---> COMPUTE AND STUFF PRINT DATE.
+35 DO PRTDAT(WVDFN,DUZ(2),WVTYPE,WVPURP,.X)
+36 DO PUT^DDSVAL(DIE,DA,.11,X)
+37 ;---> COMPUTE AND STUFF COMPLETE BY DATE.
+38 SET X=$$NDELQ1^WVUTL4
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 #790.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(^WV(790.403,TYPE,0),U,2)
QUIT
+15 SET X2=$PIECE($GET(^WV(790.02,DUZ2,0)),U,6)
+16 SET X2=$SELECT(X2:-X2,1:-30)
+17 if '$DATA(^WV(790,DFN,0))
QUIT
+18 ;---> IF THIS PURPOSE IS A RESULT LETTER, SET PRINT DATE=TODAY, QUIT.
+19 if '$DATA(^WV(790.404,PURP,0))
QUIT
+20 IF $PIECE(^WV(790.404,PURP,0),U,6)
SET DATE=DT
QUIT
+21 ;---> IF THIS IS NOT ASSOCIATED WITH BR/CX NEEDS, QUIT WITH DATE="".
+22 if $PIECE(^WV(790.404,PURP,0),U,5)=""
QUIT
+23 if $PIECE(^WV(790.404,PURP,0),U,5)="CX"
SET P=11
SET Q=12
+24 if $PIECE(^WV(790.404,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(^WV(790,DFN,0),U,P)
QUIT
+27 ;---> QUIT IF THIS PATIENT HAS NO BR/CX NEED DUE DATE.
+28 SET X=$PIECE(^WV(790,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
