WV22PST ;HIOFO/FT-WV*1*22 POST INSTALLATION ROUTINE; 1/30/07 9:29am
;;1.0;WOMEN'S HEALTH;**22**;Sep 30, 1998;Build 1
;
ENV ;Main entry point for Environment check point.
;
S XPDABORT=""
D PROGCHK(.XPDABORT) ;checks programmer variables
I XPDABORT="" K XPDABORT
Q
;
POST ;Main entry point for Post-init items.
;
;Change the CPT codes for mammograms in file 790.2
N X,Y,Z,OLDCPT,NEWCPT
F X="MAMMOGRAM DX BILAT","MAMMOGRAM DX UNILAT","MAMMOGRAM SCREENING" D
. S Y=$O(^WV(790.2,"B",X,0)) Q:Y'>0
. S Z=$G(^WV(790.2,Y,0)) Q:Z=""
. S OLDCPT=$P(Z,"^",8) I OLDCPT'=76090,OLDCPT'=76091,OLDCPT'=76092 Q
. S NEWCPT=$S(X="MAMMOGRAM DX BILAT":77056,X="MAMMOGRAM DX UNILAT":77055,X="MAMMOGRAM SCREENING":77057,1:"") Q:NEWCPT=""
. S $P(Z,"^",8)=NEWCPT,^WV(790.2,Y,0)=Z
. ; update cross-reference
. K ^WV(790.2,"AC",OLDCPT,Y)
. S ^WV(790.2,"AC",NEWCPT,Y)=""
Q
;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
;
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
.D BMES^XPDUTL("*****")
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.D MES^XPDUTL("*****")
.S XPDABORT=2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWV22PST 1197 printed Dec 13, 2024@02:46:29 Page 2
WV22PST ;HIOFO/FT-WV*1*22 POST INSTALLATION ROUTINE; 1/30/07 9:29am
+1 ;;1.0;WOMEN'S HEALTH;**22**;Sep 30, 1998;Build 1
+2 ;
ENV ;Main entry point for Environment check point.
+1 ;
+2 SET XPDABORT=""
+3 ;checks programmer variables
DO PROGCHK(.XPDABORT)
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
POST ;Main entry point for Post-init items.
+1 ;
+2 ;Change the CPT codes for mammograms in file 790.2
+3 NEW X,Y,Z,OLDCPT,NEWCPT
+4 FOR X="MAMMOGRAM DX BILAT","MAMMOGRAM DX UNILAT","MAMMOGRAM SCREENING"
Begin DoDot:1
+5 SET Y=$ORDER(^WV(790.2,"B",X,0))
if Y'>0
QUIT
+6 SET Z=$GET(^WV(790.2,Y,0))
if Z=""
QUIT
+7 SET OLDCPT=$PIECE(Z,"^",8)
IF OLDCPT'=76090
IF OLDCPT'=76091
IF OLDCPT'=76092
QUIT
+8 SET NEWCPT=$SELECT(X="MAMMOGRAM DX BILAT":77056,X="MAMMOGRAM DX UNILAT":77055,X="MAMMOGRAM SCREENING":77057,1:"")
if NEWCPT=""
QUIT
+9 SET $PIECE(Z,"^",8)=NEWCPT
SET ^WV(790.2,Y,0)=Z
+10 ; update cross-reference
+11 KILL ^WV(790.2,"AC",OLDCPT,Y)
+12 SET ^WV(790.2,"AC",NEWCPT,Y)=""
End DoDot:1
+13 QUIT
+14 ;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
+1 ;
+2 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+3 DO BMES^XPDUTL("*****")
+4 DO MES^XPDUTL("Your programming variables are not set up properly.")
+5 DO MES^XPDUTL("Installation aborted.")
+6 DO MES^XPDUTL("*****")
+7 SET XPDABORT=2
End DoDot:1
+8 QUIT
