- BWUTL4 ;IHS/ANMC/MWR - UTIL: DATE DEFAULTS, OTH VALUES;23-Jan-2009 10:35;DU
- ;;2.0;WOMEN'S HEALTH;**8,9,11**;MAY 16, 1996
- ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- ;; UTILITY: DEFAULT "COMPLETE BY" DATES FOR NOTIFS AND PROCEDURES,
- ;; STATUS TEXT, DIAG TEXT, NORMAL VALUE, COLP VALUE, MARGIN? VALUE.
- ;
- ;
- NDELQ() ;EP
- ;---> FOR NOTIFICATIONS:
- ;---> COMPUTE DEFAULT "COMPLETE BY (DATE)" - DATE AT WHICH A
- ;---> NOTIFICATION BECOMES DELINQUENT. CALLED BY BW NOTIF-EDITBLK-1.
- ;---> DEFAULT IS CREATED WHEN SCREEN IS FIRST LOADED.
- ;---> CODE HERE SETS X=EITHER 1: PRINT DATE (IF PRINTABLE), OR
- ;---> 2: DATE NOTIFICATION OPENED, OR
- ;---> 3: TODAY'S DATE
- ;---> THEN $$NDELQ1() IS CALLED TO ADD 30 DAYS UNTIL DELINQUENT.
- ;---> REQUIRED VARIABLE: DA (IEN OF NOTIFICATION).
- N X
- Q:'$D(DA) ""
- Q:'DA ""
- Q:'$D(^BWNOT(DA,0)) ""
- S X=$P(^BWNOT(DA,0),U,11)
- S:'X X=$P(^BWNOT(DA,0),U,2)
- S:'X X=DT
- Q $$NDELQ1
- ;
- NDELQ1() ;EP
- ;---> FOR NOTIFICATIONS:
- ;---> COMPUTE "COMPLETE BY (DATE)". CALLED BY UPDATE/EDIT OF
- ;---> "PRINT DATE:" IN BW NOTIF-EDITBLK-1.
- ;---> X1=EITHER NEW PRINT DATE, OR DATE NOTIF OPENED, OR TODAY.
- ;---> X2=30 DAYS ADDED TILL NOTIFICATION BECOMES DELINQUENT.
- ;---> REQUIRED VARIABLE: X=PRINT DATE, OR DATE OPENED, OR TODAY.
- N %H,X1,X2
- Q:'$D(X) ""
- Q:'X ""
- S X1=X,X2=30
- D C^%DTC
- Q X
- ;
- PDELQ(DA,DUZ2) ;EP
- ;---> FOR PROCEDURES:
- ;---> COMPUTE DEFAULT "COMPLETE BY (DATE)" - DATE AT WHICH A
- ;---> PROCEDURE BECOMES DELINQUENT. CALLED BY BW PROC-EDITBLK-1.
- ;---> DEFAULT IS CREATED WHEN SCREEN IS FIRST LOADED.
- ;---> CODE HERE FIRST RETRIEVES STORED DATE OF PROCEDURE, THEN CALLS
- ;---> $$DELQ1 TO COMPUTE "COMPLETE BY (DATE)".
- ;---> REQUIRED VARIABLE: DA (IEN OF PROCEDURE), DUZ2=DUZ(2).
- Q:'$G(DA)!('$G(DUZ2)) ""
- Q:'$D(^BWPCD(DA,0)) ""
- Q:'$P(^BWPCD(DA,0),U,12) ""
- Q $$PDELQ1(DA,$P(^BWPCD(DA,0),U,12),DUZ2)
- ;
- PDELQ1(BWDA,BWDT,BWDUZ2) ;EP
- ;---> FOR PROCEDURES:
- ;---> COMPUTE "COMPLETE BY (BWDT)". CALLED BY UPBWDT/EDIT OF
- ;---> "BWDT OF PROCEDURE" IN BW PROC-EDITBLK-1.
- ;---> X1=BWDT OF PROCEDURE, X2=DEFAULT NUMBER OF BWDAYS THE
- ;---> PROCEDURE IS ALLOWED TO REMAIN OPEN BEFORE BECOMING DELINQUENT.
- ;---> REQUIRED VARIABLE: BWDA=IEN OF PROCEDURE, BWDT=DATE OF PROCEDURE,
- ;---> BWDUZ2=DUZ(2).
- N %H,X,X1,X2
- Q:'$G(BWDA)!('$G(BWDT)) ""
- Q:'$D(^BWPCD(BWDA,0)) ""
- S X2=$P(^BWPCD(BWDA,0),U,4),X1=BWDT
- Q:'X2 ""
- Q:'$D(^BWSITE(BWDUZ2,X2)) ""
- S X2=$P(^BWSITE(BWDUZ2,X2),U,3)
- D C^%DTC
- Q X
- ;
- STATUS() ;EP
- ;---> PROVIDES STATUS (OPEN, DELINQUENT, OR CLOSED).
- ;---> Y MUST EQUAL ZERO NODE OF NOTIFICATION.
- ;---> REQUIRED VARIABLE: Y=ZERO NODE OF PROCEDURE, DT=FFDATE
- Q:'$D(Y) "UNKNOWN"
- Q:$P(Y,U,14)="c" "CLOSED"
- Q:$P(Y,U,14)="n" "NEW"
- Q:$P(Y,U,14)="e" "ERROR"
- Q:$P(Y,U,13)]""&($P(Y,U,13)<DT) "DELINQ"
- Q "OPEN"
- ;
- DIAG(IEN) ;EP
- ;---> RETURN TEXT OF RESULT/DIAGNOSIS.
- ;---> REQUIRED VARIABLE X=IEN IN BW RESULTS/DIAGNOSIS FILE 9002086.31.
- Q:'$G(IEN) "NOT ENTERED"
- Q:'$D(^BWDIAG(IEN,0)) "UNKNOWN POINTER"
- Q $P(^BWDIAG(IEN,0),U)
- ;
- PRIOR() ;EP
- ;---> PROVIDE PRIORITY FOR THIS RESULT/DIAGNOSIS (DEFAULT=10).
- ;---> REQUIRED VARIABLE X=IEN IN BW RESULTS/DIAGNOSIS FILE.
- Q:'$D(X)!(X']"") 10
- Q:'$D(^BWDIAG(X,0)) 10
- Q:'$P(^BWDIAG(X,0),U,2) 10
- Q $P(^BWDIAG(X,0),U,2)
- ;
- NORMAL(X) ;EP
- ;---> PROVIDE NORMAL/ABNORMAL FOR THIS RESULT/DIAGNOSIS.
- ;---> WILL RETURN 0 IF NORMAL, 1 IF ABNORMAL (DEFAULT=1),
- ;---> 2 IF NO RESULT (EITHER THE PROCEDURE HAS NO RESULT OR
- ;---> THE RESULT/DIAGNOSIS HAS "NO RESULT" FOR FIELD #.21).
- ;---> REQUIRED VARIABLE X=IEN IN BW RESULTS/DIAGNOSIS FILE.
- Q:'$D(X)!(X']"") 2
- Q:'$D(^BWDIAG(X,0)) 2
- Q:$P(^BWDIAG(X,0),U,21)="" 2
- Q $P(^BWDIAG(X,0),U,21)
- ;
- COLP(DA) ;EP
- ;---> DETERMINE WHETHER OR NOT THE CURRENT PROCEDURE REQUIRES
- ;---> PAGE 2 OF PROCEDURE EDIT SCREENS FOR COLPOSCOPY RESULTS.
- ;---> RETURNS 1 IF COLP-TYPE RESULTS, OTHERWISE 0.
- ;---> DA=IEN OF PROCEDURE IN PROC FILE #9002086.1.
- N Y
- Q:'$G(DA) 0
- Q:'$D(^BWPCD(DA,0)) 0
- S Y=$P(^BWPCD(DA,0),U,4)
- Q:'Y 0
- Q:'$D(^BWPN(Y,0)) 0
- Q:$P(^BWPN(Y,0),U,3)<1 0
- Q 1
- ;
- COLPA(DA) ;EP
- ;---> LOOK FOR ASSOCIATED COLPOSCOPY, RETURN ITS ACC# AND DATE.
- N X,Y
- Q:'$G(DA) ""
- S Y=$$COLP0(DA)
- Q:Y="" "None"
- S X=$P(Y,U)_" on "_$$SLDT2^BWUTL5($P(Y,U,12))
- I $P(Y,U,5) Q X_"^"_$P(^BWDIAG($P(Y,U,5),0),U)
- Q X_"^"_"Not entered"
- ;
- COLP0(DA) ;EP
- ;---> IF THERE IS AN ASSOC'D COLP, RETURN ITS ZERO NODE.
- N Y
- Q:'$G(DA) ""
- Q:'$D(^BWPCD(DA,0)) ""
- Q:'$D(^BWPCD("ACOLP",DA)) ""
- S Y=$O(^BWPCD("ACOLP",DA,0)),Y=$O(^BWPCD("ACOLP",DA,Y,0))
- Q:'$D(^BWPCD(Y,0)) ""
- Q ^BWPCD(Y,0)
- ;
- MARGIN(DA) ;EP
- ;---> DETERMINE WHETHER THE "MARGINS CLEAR?" QUESTION (PAGE 2 OF
- ;---> PROCEDURE EDIT) SHOULD BE ASKED FOR THIS PROCEDURE.
- N Y
- Q:'$G(DA) 0
- Q:'$D(^BWPCD(DA,0)) 0
- S Y=$P(^BWPCD(DA,0),U,4)
- Q:'Y 0
- Q:'$D(^BWPN(Y,0)) 0
- Q:$P(^BWPN(Y,0),U,11)<1 0
- Q 1
- ;
- STAGE(STAGE) ;EP
- ;---> RETURN THE TEXT OF THE STAGE OF CARCINOMA.
- Q:'$G(STAGE) ""
- Q:'$D(^DD(9002086.1,.31,0)) "^DD MISSING"
- Q $P($P(^DD(9002086.1,.31,0),STAGE_":",2),";")
- HPVA(DA) ;
- ; ---> LOOK FOR ASSOCIATED HPV SCREENING, RETURN ITS ACC# AND DATE
- N X,Y
- Q:'$G(DA) ""
- S Y=$$HPVA0(DA)
- Q:Y="" "None"
- S X=$P(Y,U)_" on "_$$SLDT2^BWUTL5($P(Y,U,12))
- I $P(Y,U,5) Q X_"^"_$P(^BWDIAG($P(Y,U,5),0),U)
- Q X_"^"_"Not entered"
- HPVA0(DA) ;
- ;---> IF THERE IS AN ASSOC'D COLP, RETURN ITS ZERO NODE.
- N Y
- Q:'$G(DA) ""
- Q:'$D(^BWPCD(DA,0)) ""
- Q:'$D(^BWPCD("AHPV",DA)) ""
- S Y=$O(^BWPCD("AHPV",DA,0)),Y=$O(^BWPCD("AHPV",DA,Y,0))
- Q:'$D(^BWPCD(Y,0)) ""
- Q ^BWPCD(Y,0)
- BWUTL4 ;IHS/ANMC/MWR - UTIL: DATE DEFAULTS, OTH VALUES;23-Jan-2009 10:35;DU
- +1 ;;2.0;WOMEN'S HEALTH;**8,9,11**;MAY 16, 1996
- +2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- +3 ;; UTILITY: DEFAULT "COMPLETE BY" DATES FOR NOTIFS AND PROCEDURES,
- +4 ;; STATUS TEXT, DIAG TEXT, NORMAL VALUE, COLP VALUE, MARGIN? VALUE.
- +5 ;
- +6 ;
- NDELQ() ;EP
- +1 ;---> FOR NOTIFICATIONS:
- +2 ;---> COMPUTE DEFAULT "COMPLETE BY (DATE)" - DATE AT WHICH A
- +3 ;---> NOTIFICATION BECOMES DELINQUENT. CALLED BY BW NOTIF-EDITBLK-1.
- +4 ;---> DEFAULT IS CREATED WHEN SCREEN IS FIRST LOADED.
- +5 ;---> CODE HERE SETS X=EITHER 1: PRINT DATE (IF PRINTABLE), OR
- +6 ;---> 2: DATE NOTIFICATION OPENED, OR
- +7 ;---> 3: TODAY'S DATE
- +8 ;---> THEN $$NDELQ1() IS CALLED TO ADD 30 DAYS UNTIL DELINQUENT.
- +9 ;---> REQUIRED VARIABLE: DA (IEN OF NOTIFICATION).
- +10 NEW X
- +11 IF '$DATA(DA)
- QUIT ""
- +12 IF 'DA
- QUIT ""
- +13 IF '$DATA(^BWNOT(DA,0))
- QUIT ""
- +14 SET X=$PIECE(^BWNOT(DA,0),U,11)
- +15 IF 'X
- SET X=$PIECE(^BWNOT(DA,0),U,2)
- +16 IF 'X
- SET X=DT
- +17 QUIT $$NDELQ1
- +18 ;
- NDELQ1() ;EP
- +1 ;---> FOR NOTIFICATIONS:
- +2 ;---> COMPUTE "COMPLETE BY (DATE)". CALLED BY UPDATE/EDIT OF
- +3 ;---> "PRINT DATE:" IN BW NOTIF-EDITBLK-1.
- +4 ;---> X1=EITHER NEW PRINT DATE, OR DATE NOTIF OPENED, OR TODAY.
- +5 ;---> X2=30 DAYS ADDED TILL NOTIFICATION BECOMES DELINQUENT.
- +6 ;---> REQUIRED VARIABLE: X=PRINT DATE, OR DATE OPENED, OR TODAY.
- +7 NEW %H,X1,X2
- +8 IF '$DATA(X)
- QUIT ""
- +9 IF 'X
- QUIT ""
- +10 SET X1=X
- SET X2=30
- +11 DO C^%DTC
- +12 QUIT X
- +13 ;
- PDELQ(DA,DUZ2) ;EP
- +1 ;---> FOR PROCEDURES:
- +2 ;---> COMPUTE DEFAULT "COMPLETE BY (DATE)" - DATE AT WHICH A
- +3 ;---> PROCEDURE BECOMES DELINQUENT. CALLED BY BW PROC-EDITBLK-1.
- +4 ;---> DEFAULT IS CREATED WHEN SCREEN IS FIRST LOADED.
- +5 ;---> CODE HERE FIRST RETRIEVES STORED DATE OF PROCEDURE, THEN CALLS
- +6 ;---> $$DELQ1 TO COMPUTE "COMPLETE BY (DATE)".
- +7 ;---> REQUIRED VARIABLE: DA (IEN OF PROCEDURE), DUZ2=DUZ(2).
- +8 IF '$GET(DA)!('$GET(DUZ2))
- QUIT ""
- +9 IF '$DATA(^BWPCD(DA,0))
- QUIT ""
- +10 IF '$PIECE(^BWPCD(DA,0),U,12)
- QUIT ""
- +11 QUIT $$PDELQ1(DA,$PIECE(^BWPCD(DA,0),U,12),DUZ2)
- +12 ;
- PDELQ1(BWDA,BWDT,BWDUZ2) ;EP
- +1 ;---> FOR PROCEDURES:
- +2 ;---> COMPUTE "COMPLETE BY (BWDT)". CALLED BY UPBWDT/EDIT OF
- +3 ;---> "BWDT OF PROCEDURE" IN BW PROC-EDITBLK-1.
- +4 ;---> X1=BWDT OF PROCEDURE, X2=DEFAULT NUMBER OF BWDAYS THE
- +5 ;---> PROCEDURE IS ALLOWED TO REMAIN OPEN BEFORE BECOMING DELINQUENT.
- +6 ;---> REQUIRED VARIABLE: BWDA=IEN OF PROCEDURE, BWDT=DATE OF PROCEDURE,
- +7 ;---> BWDUZ2=DUZ(2).
- +8 NEW %H,X,X1,X2
- +9 IF '$GET(BWDA)!('$GET(BWDT))
- QUIT ""
- +10 IF '$DATA(^BWPCD(BWDA,0))
- QUIT ""
- +11 SET X2=$PIECE(^BWPCD(BWDA,0),U,4)
- SET X1=BWDT
- +12 IF 'X2
- QUIT ""
- +13 IF '$DATA(^BWSITE(BWDUZ2,X2))
- QUIT ""
- +14 SET X2=$PIECE(^BWSITE(BWDUZ2,X2),U,3)
- +15 DO C^%DTC
- +16 QUIT X
- +17 ;
- STATUS() ;EP
- +1 ;---> PROVIDES STATUS (OPEN, DELINQUENT, OR CLOSED).
- +2 ;---> Y MUST EQUAL ZERO NODE OF NOTIFICATION.
- +3 ;---> REQUIRED VARIABLE: Y=ZERO NODE OF PROCEDURE, DT=FFDATE
- +4 IF '$DATA(Y)
- QUIT "UNKNOWN"
- +5 IF $PIECE(Y,U,14)="c"
- QUIT "CLOSED"
- +6 IF $PIECE(Y,U,14)="n"
- QUIT "NEW"
- +7 IF $PIECE(Y,U,14)="e"
- QUIT "ERROR"
- +8 IF $PIECE(Y,U,13)]""&($PIECE(Y,U,13)<DT)
- QUIT "DELINQ"
- +9 QUIT "OPEN"
- +10 ;
- DIAG(IEN) ;EP
- +1 ;---> RETURN TEXT OF RESULT/DIAGNOSIS.
- +2 ;---> REQUIRED VARIABLE X=IEN IN BW RESULTS/DIAGNOSIS FILE 9002086.31.
- +3 IF '$GET(IEN)
- QUIT "NOT ENTERED"
- +4 IF '$DATA(^BWDIAG(IEN,0))
- QUIT "UNKNOWN POINTER"
- +5 QUIT $PIECE(^BWDIAG(IEN,0),U)
- +6 ;
- PRIOR() ;EP
- +1 ;---> PROVIDE PRIORITY FOR THIS RESULT/DIAGNOSIS (DEFAULT=10).
- +2 ;---> REQUIRED VARIABLE X=IEN IN BW RESULTS/DIAGNOSIS FILE.
- +3 IF '$DATA(X)!(X']"")
- QUIT 10
- +4 IF '$DATA(^BWDIAG(X,0))
- QUIT 10
- +5 IF '$PIECE(^BWDIAG(X,0),U,2)
- QUIT 10
- +6 QUIT $PIECE(^BWDIAG(X,0),U,2)
- +7 ;
- NORMAL(X) ;EP
- +1 ;---> PROVIDE NORMAL/ABNORMAL FOR THIS RESULT/DIAGNOSIS.
- +2 ;---> WILL RETURN 0 IF NORMAL, 1 IF ABNORMAL (DEFAULT=1),
- +3 ;---> 2 IF NO RESULT (EITHER THE PROCEDURE HAS NO RESULT OR
- +4 ;---> THE RESULT/DIAGNOSIS HAS "NO RESULT" FOR FIELD #.21).
- +5 ;---> REQUIRED VARIABLE X=IEN IN BW RESULTS/DIAGNOSIS FILE.
- +6 IF '$DATA(X)!(X']"")
- QUIT 2
- +7 IF '$DATA(^BWDIAG(X,0))
- QUIT 2
- +8 IF $PIECE(^BWDIAG(X,0),U,21)=""
- QUIT 2
- +9 QUIT $PIECE(^BWDIAG(X,0),U,21)
- +10 ;
- COLP(DA) ;EP
- +1 ;---> DETERMINE WHETHER OR NOT THE CURRENT PROCEDURE REQUIRES
- +2 ;---> PAGE 2 OF PROCEDURE EDIT SCREENS FOR COLPOSCOPY RESULTS.
- +3 ;---> RETURNS 1 IF COLP-TYPE RESULTS, OTHERWISE 0.
- +4 ;---> DA=IEN OF PROCEDURE IN PROC FILE #9002086.1.
- +5 NEW Y
- +6 IF '$GET(DA)
- QUIT 0
- +7 IF '$DATA(^BWPCD(DA,0))
- QUIT 0
- +8 SET Y=$PIECE(^BWPCD(DA,0),U,4)
- +9 IF 'Y
- QUIT 0
- +10 IF '$DATA(^BWPN(Y,0))
- QUIT 0
- +11 IF $PIECE(^BWPN(Y,0),U,3)<1
- QUIT 0
- +12 QUIT 1
- +13 ;
- COLPA(DA) ;EP
- +1 ;---> LOOK FOR ASSOCIATED COLPOSCOPY, RETURN ITS ACC# AND DATE.
- +2 NEW X,Y
- +3 IF '$GET(DA)
- QUIT ""
- +4 SET Y=$$COLP0(DA)
- +5 IF Y=""
- QUIT "None"
- +6 SET X=$PIECE(Y,U)_" on "_$$SLDT2^BWUTL5($PIECE(Y,U,12))
- +7 IF $PIECE(Y,U,5)
- QUIT X_"^"_$PIECE(^BWDIAG($PIECE(Y,U,5),0),U)
- +8 QUIT X_"^"_"Not entered"
- +9 ;
- COLP0(DA) ;EP
- +1 ;---> IF THERE IS AN ASSOC'D COLP, RETURN ITS ZERO NODE.
- +2 NEW Y
- +3 IF '$GET(DA)
- QUIT ""
- +4 IF '$DATA(^BWPCD(DA,0))
- QUIT ""
- +5 IF '$DATA(^BWPCD("ACOLP",DA))
- QUIT ""
- +6 SET Y=$ORDER(^BWPCD("ACOLP",DA,0))
- SET Y=$ORDER(^BWPCD("ACOLP",DA,Y,0))
- +7 IF '$DATA(^BWPCD(Y,0))
- QUIT ""
- +8 QUIT ^BWPCD(Y,0)
- +9 ;
- MARGIN(DA) ;EP
- +1 ;---> DETERMINE WHETHER THE "MARGINS CLEAR?" QUESTION (PAGE 2 OF
- +2 ;---> PROCEDURE EDIT) SHOULD BE ASKED FOR THIS PROCEDURE.
- +3 NEW Y
- +4 IF '$GET(DA)
- QUIT 0
- +5 IF '$DATA(^BWPCD(DA,0))
- QUIT 0
- +6 SET Y=$PIECE(^BWPCD(DA,0),U,4)
- +7 IF 'Y
- QUIT 0
- +8 IF '$DATA(^BWPN(Y,0))
- QUIT 0
- +9 IF $PIECE(^BWPN(Y,0),U,11)<1
- QUIT 0
- +10 QUIT 1
- +11 ;
- STAGE(STAGE) ;EP
- +1 ;---> RETURN THE TEXT OF THE STAGE OF CARCINOMA.
- +2 IF '$GET(STAGE)
- QUIT ""
- +3 IF '$DATA(^DD(9002086.1,.31,0))
- QUIT "^DD MISSING"
- +4 QUIT $PIECE($PIECE(^DD(9002086.1,.31,0),STAGE_":",2),";")
- HPVA(DA) ;
- +1 ; ---> LOOK FOR ASSOCIATED HPV SCREENING, RETURN ITS ACC# AND DATE
- +2 NEW X,Y
- +3 IF '$GET(DA)
- QUIT ""
- +4 SET Y=$$HPVA0(DA)
- +5 IF Y=""
- QUIT "None"
- +6 SET X=$PIECE(Y,U)_" on "_$$SLDT2^BWUTL5($PIECE(Y,U,12))
- +7 IF $PIECE(Y,U,5)
- QUIT X_"^"_$PIECE(^BWDIAG($PIECE(Y,U,5),0),U)
- +8 QUIT X_"^"_"Not entered"
- HPVA0(DA) ;
- +1 ;---> IF THERE IS AN ASSOC'D COLP, RETURN ITS ZERO NODE.
- +2 NEW Y
- +3 IF '$GET(DA)
- QUIT ""
- +4 IF '$DATA(^BWPCD(DA,0))
- QUIT ""
- +5 IF '$DATA(^BWPCD("AHPV",DA))
- QUIT ""
- +6 SET Y=$ORDER(^BWPCD("AHPV",DA,0))
- SET Y=$ORDER(^BWPCD("AHPV",DA,Y,0))
- +7 IF '$DATA(^BWPCD(Y,0))
- QUIT ""
- +8 QUIT ^BWPCD(Y,0)