ACPT29P2 ; IHS/SD/SDR - ACPT V2.09 patch 2 ;4/21/08 14:11
;;2.09;CPT FILES;**2**;JAN 2,2009
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
;
S X=$P(^VA(200,DUZ,0),U)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM),!
;
NEW ACPTQUIT
S ACPTQUIT=0
I '$$VCHK("XU","8",2) S ACPTQUIT=2
;
I '$$VCHK("XT","7.3",2) S ACPTQUIT=2
;
I '$$VCHK("DI","21",2) S ACPTQUIT=2
;
I '$$VCHK("ACPT","2.09",2) S ACPTQUIT=2
;
NEW DA,DIC
S X="ACPT",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","ACPT")) D S ACPTQUIT=2
. W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""ACPT"" prefix.",IOM)
. W !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
. W !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7
.Q
;
I ACPTQUIT D SORRY(ACPTQUIT) Q
;
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W:'$D(ZTQUEUED) *7,!,$$CJ^XLFSTR("Sorry....",IOM),$$DIR^XBDIR("E","Press RETURN")
Q
;
VCHK(ACPTPRE,ACPTVER,ACPTQUIT) ; Check versions needed.
;
NEW ACPTV
S ACPTV=$$VERSION^XPDUTL(ACPTPRE)
W !,$$CJ^XLFSTR("Need at least "_ACPTPRE_" v "_ACPTVER_"....."_ACPTPRE_" v "_ACPTV_" Present",IOM)
I ACPTV<ACPTVER W *7,!,$$CJ^XLFSTR("^^^^**NEEDS FIXED**^^^^",IOM) Q 0
Q 1
;
INSTALLD(ACPTINST) ;EP - Determine if patch ACPTINST was installed, where ACPTINST is
; the name of the INSTALL. E.g "AG*6.0*10".
;;^DIC(9.4,D0,22,D1,PAH,D2,0)=
;;(#.01) PATCH APPLICATION HISTORY [1F] ^ (#.02)DATE APPLIED [2D] ^ (#.03) APPLIED BY [3P] ^
NEW DIC,X,Y
S X=$P(ACPTINST,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",22,",X=$P(ACPTINST,"*",2)
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(ACPTINST,"*",3)
D ^DIC
Q $S(Y<1:0,1:1)
;
LAST(PKG,VER) ;EP - returns last patch applied for a Package, PATCH^DATE
; Patch includes Seq # if Released
N PKGIEN,VERIEN,LATEST,PATCH,SUBIEN
I $G(VER)="" S VER=$$VERSION^XPDUTL(PKG) Q:'VER -1
S PKGIEN=$O(^DIC(9.4,"B",PKG,"")) Q:'PKGIEN -1
S VERIEN=$O(^DIC(9.4,PKGIEN,22,"B",VER,"")) Q:'VERIEN -1
S LATEST=-1,PATCH=-1,SUBIEN=0
F S SUBIEN=$O(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN)) Q:SUBIEN'>0 D
. I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST S LATEST=$P(^(0),U,2),PATCH=$P(^(0),U)
. I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST,$P(^(0),U)>PATCH S PATCH=$P(^(0),U)
Q PATCH_U_LATEST
LOAD ;
NEW ACPTDA,ACPTI,ACPTLN,DA,DIE,DR
F ACPTI=1:1 S ACPTLN=$P($T(DATA+ACPTI^ACPT29P2),";;",2) Q:ACPTLN="END" D
.S ACPTCODE=$P(ACPTLN,U)
.S ACPTSHRT=$P(ACPTLN,U,2)
.S ACPTDESC=$P(ACPTLN,U,3)
.S ACPTIEN=$O(^ICPT("B",ACPTCODE,0)) ; find the code's record number
.I '$D(^ICPT("B",ACPTCODE)) D ; if there isn't one, create it
..S ACPTIEN=$A($E(ACPTCODE,1))_$E(ACPTCODE,2,5)
..S ^ICPT(ACPTIEN,0)=ACPTCODE ; CPT Code field (.01)
..S ^ICPT("B",ACPTCODE,ACPTIEN)="" ; index of CPT Codes
..S $P(^ICPT(ACPTIEN,0),U,6)=3090901
..I ACPTCODE="Q2023" S $P(^ICPT(ACPTIEN,0),U,6)=3090701
.;
.S ACPTNODE=$G(^ICPT(ACPTIEN,0)) ; get record's header node
.I ACPTSHRT'="" S $P(ACPTNODE,U,2)=ACPTSHRT ; update it
.S $P(ACPTNODE,U,7)="" ; clear Date Deleted field (8)
.S ^ICPT(ACPTIEN,0)=ACPTNODE ; update header node
.;
.D TEXT(.ACPTDESC) ; convert string to WP array
.K ^ICPT(ACPTIEN,"D") ; clean out old Description (50)
.M ^ICPT(ACPTIEN,"D")=ACPTDESC ; copy array to field, incl. header
.;
.S ACPTEDT=$O(^ICPT(ACPTIEN,60,"B",9999999),-1) ; find the last
.N ACPTEIEN S ACPTEIEN=$O(^ICPT(ACPTIEN,60,"B",+ACPTEDT,0)) ; its IEN
.;
.I ACPTEDT=3090901,ACPTEIEN D ; if there is one for this install date
..Q:$P($G(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2) ; if active, we're fine
..; otherwise, we need to activate it:
..K DIC,DIE,DA,DIR,X,Y
..S DA=+ACPTEIEN ; IEN of last Effective Date
..S DA(1)=ACPTIEN ; IEN of its parent CPT
..S DIE="^ICPT("_DA(1)_",60," ; Effective Date (60/81.02)
..S DR=".02////1" ; set Status field to ACTIVE
..N DIDEL,DTOUT ; other parameters for DIE
..D ^DIE ; Fileman Data Edit call
.;
.E D ; if not, then we need one
..K DIC,DIE,DA,X,Y,DIR
..S DA(1)=ACPTIEN ; into subfile under new entry
..S DIC="^ICPT("_DA(1)_",60," ; Effective Date (60/81.02)
..S DIC(0)="L" ; LAYGO
..S DIC("P")=$P(^DD(81,60,0),U,2) ; subfile # & specifier codes
..S X="09/01/2009" ; new entry for 9/1/2009
..I ACPTCODE="Q2023" S X="07/01/2009"
..S DIC("DR")=".02////1" ; with Status = 1 (active)
..N DLAYGO,Y,DTOUT,DUOUT ; other parameters
..D ^DIC ; Fileman LAYGO lookup
Q
TEXT(ACPTDESC) ; convert Description text to Word-Processing data type
; input: .ACPTDESC = passed by reference, starts out as long string,
; ends as Fileman WP-format array complete with header
;
N ACPTSTRN S ACPTSTRN=ACPTDESC ; copy string out
K ACPTDESC ; clear what will now become a WP array
N ACPTCNT S ACPTCNT=0 ; count WP lines for header
;
F Q:ACPTSTRN="" D ; loop until ACPTSTRN is fully transformed
.;
.N ACPTBRK S ACPTBRK=0 ; character position to break at
.;
.D ; find the character position to break at
..N ACPTRY ; break position to try
..S ACPTRY=$L(ACPTSTRN) ; how long is the string?
..I ACPTRY<81 S ACPTBRK=ACPTRY Q ; if 1 full line or less, we're done
..;
..F ACPTRY=80:-1:2 D Q:ACPTBRK
...I $E(ACPTSTRN,ACPTRY+1)=" " D Q ; can break on a space
....S $E(ACPTSTRN,ACPTRY+1)="" ; remove the space
....S ACPTBRK=ACPTRY ; and let's break here
...;
...I "&_+-*/<=>}])|:;,.?!"[$E(ACPTSTRN,ACPTRY) D Q ; on delimiter?
....S ACPTBRK=ACPTRY ; so let's break here
..;
..Q:ACPTBRK ; if we found a good spot to break, we're done
..;
..S ACPTBRK=80 ; otherwise, hard-break on 80 (weird content)
.;
.S ACPTCNT=ACPTCNT+1 ; one more line
.S ACPTDESC(ACPTCNT,0)=$E(ACPTSTRN,1,ACPTBRK) ; copy line into array
.S $E(ACPTSTRN,1,ACPTBRK)="" ; & remove it from the string
;
S ACPTDESC(0)="^81.01A^"_ACPTCNT_U_ACPTCNT_U_DT ; set WP header
;
Q
DATA ;
;;G9141^INFLUENZA A IMM ORDER/ADMIN^Influenza A (H1N1) immunization administration (includes the physician counseling the patient/family)
;;G9142^INFLUENZA A VACC^Influenza A (H1N1) vaccine, any route of administration
;;Q2023^Xyntha, inj^INJECTION, FACTOR VIII (ANTIHEMOPHILIC FACTOR, RECOMBINANT) (XYNTHA), PER I.U.
;;END
ACPT29P2 ; IHS/SD/SDR - ACPT V2.09 patch 2 ;4/21/08 14:11
+1 ;;2.09;CPT FILES;**2**;JAN 2,2009
+2 ;
+3 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+4 ;
+5 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+6 ;
+7 SET X=$PIECE(^VA(200,DUZ,0),U)
+8 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+9 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT">TEXT">TEXT">TEXT(+2),";",4)_" V "_$PIECE($TEXT">TEXT">TEXT">TEXT(+2),";",3)_" Patch "_$PIECE($TEXT">TEXT">TEXT">TEXT(+2),";",5)_".",IOM),!
+10 ;
+11 NEW ACPTQUIT
+12 SET ACPTQUIT=0
+13 IF '$$VCHK("XU","8",2)
SET ACPTQUIT=2
+14 ;
+15 IF '$$VCHK("XT","7.3",2)
SET ACPTQUIT=2
+16 ;
+17 IF '$$VCHK("DI","21",2)
SET ACPTQUIT=2
+18 ;
+19 IF '$$VCHK("ACPT","2.09",2)
SET ACPTQUIT=2
+20 ;
+21 NEW DA,DIC
+22 SET X="ACPT"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+23 DO IX^DIC
+24 IF Y<0
IF $DATA(^DIC(9.4,"C","ACPT"))
Begin DoDot:1
+25 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""ACPT"" prefix.",IOM)
+26 WRITE !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
+27 WRITE !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7
+28 QUIT
End DoDot:1
SET ACPTQUIT=2
+29 ;
+30 IF ACPTQUIT
DO SORRY(ACPTQUIT)
QUIT
+31 ;
+32 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+33 ;
+34 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+35 QUIT
+36 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 IF '$DATA(ZTQUEUED)
WRITE *7,!,$$CJ^XLFSTR("Sorry....",IOM),$$DIR^XBDIR("E","Press RETURN")
+4 QUIT
+5 ;
VCHK(ACPTPRE,ACPTVER,ACPTQUIT) ; Check versions needed.
+1 ;
+2 NEW ACPTV
+3 SET ACPTV=$$VERSION^XPDUTL(ACPTPRE)
+4 WRITE !,$$CJ^XLFSTR("Need at least "_ACPTPRE_" v "_ACPTVER_"....."_ACPTPRE_" v "_ACPTV_" Present",IOM)
+5 IF ACPTV<ACPTVER
WRITE *7,!,$$CJ^XLFSTR("^^^^**NEEDS FIXED**^^^^",IOM)
QUIT 0
+6 QUIT 1
+7 ;
INSTALLD(ACPTINST) ;EP - Determine if patch ACPTINST was installed, where ACPTINST is
+1 ; the name of the INSTALL. E.g "AG*6.0*10".
+2 ;;^DIC(9.4,D0,22,D1,PAH,D2,0)=
+3 ;;(#.01) PATCH APPLICATION HISTORY [1F] ^ (#.02)DATE APPLIED [2D] ^ (#.03) APPLIED BY [3P] ^
+4 NEW DIC,X,Y
+5 SET X=$PIECE(ACPTINST,"*",1)
+6 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+7 DO IX^DIC
+8 IF Y<1
QUIT 0
+9 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(ACPTINST,"*",2)
+10 DO ^DIC
+11 IF Y<1
QUIT 0
+12 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(ACPTINST,"*",3)
+13 DO ^DIC
+14 QUIT $SELECT(Y<1:0,1:1)
+15 ;
LAST(PKG,VER) ;EP - returns last patch applied for a Package, PATCH^DATE
+1 ; Patch includes Seq # if Released
+2 NEW PKGIEN,VERIEN,LATEST,PATCH,SUBIEN
+3 IF $GET(VER)=""
SET VER=$$VERSION^XPDUTL(PKG)
IF 'VER
QUIT -1
+4 SET PKGIEN=$ORDER(^DIC(9.4,"B",PKG,""))
IF 'PKGIEN
QUIT -1
+5 SET VERIEN=$ORDER(^DIC(9.4,PKGIEN,22,"B",VER,""))
IF 'VERIEN
QUIT -1
+6 SET LATEST=-1
SET PATCH=-1
SET SUBIEN=0
+7 FOR
SET SUBIEN=$ORDER(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN))
IF SUBIEN'>0
QUIT
Begin DoDot:1
+8 IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST
SET LATEST=$PIECE(^(0),U,2)
SET PATCH=$PIECE(^(0),U)
+9 IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST
IF $PIECE(^(0),U)>PATCH
SET PATCH=$PIECE(^(0),U)
End DoDot:1
+10 QUIT PATCH_U_LATEST
LOAD ;
+1 NEW ACPTDA,ACPTI,ACPTLN,DA,DIE,DR
+2 FOR ACPTI=1:1
SET ACPTLN=$PIECE($TEXT(DATA+ACPTI^ACPT29P2),";;",2)
IF ACPTLN="END"
QUIT
Begin DoDot:1
+3 SET ACPTCODE=$PIECE(ACPTLN,U)
+4 SET ACPTSHRT=$PIECE(ACPTLN,U,2)
+5 SET ACPTDESC=$PIECE(ACPTLN,U,3)
+6 ; find the code's record number
SET ACPTIEN=$ORDER(^ICPT("B",ACPTCODE,0))
+7 ; if there isn't one, create it
IF '$DATA(^ICPT("B",ACPTCODE))
Begin DoDot:2
+8 SET ACPTIEN=$ASCII($EXTRACT(ACPTCODE,1))_$EXTRACT(ACPTCODE,2,5)
+9 ; CPT Code field (.01)
SET ^ICPT(ACPTIEN,0)=ACPTCODE
+10 ; index of CPT Codes
SET ^ICPT("B",ACPTCODE,ACPTIEN)=""
+11 SET $PIECE(^ICPT(ACPTIEN,0),U,6)=3090901
+12 IF ACPTCODE="Q2023"
SET $PIECE(^ICPT(ACPTIEN,0),U,6)=3090701
End DoDot:2
+13 ;
+14 ; get record's header node
SET ACPTNODE=$GET(^ICPT(ACPTIEN,0))
+15 ; update it
IF ACPTSHRT'=""
SET $PIECE(ACPTNODE,U,2)=ACPTSHRT
+16 ; clear Date Deleted field (8)
SET $PIECE(ACPTNODE,U,7)=""
+17 ; update header node
SET ^ICPT(ACPTIEN,0)=ACPTNODE
+18 ;
+19 ; convert string to WP array
DO TEXT(.ACPTDESC)
+20 ; clean out old Description (50)
KILL ^ICPT(ACPTIEN,"D")
+21 ; copy array to field, incl. header
MERGE ^ICPT(ACPTIEN,"D")=ACPTDESC
+22 ;
+23 ; find the last
SET ACPTEDT=$ORDER(^ICPT(ACPTIEN,60,"B",9999999),-1)
+24 ; its IEN
NEW ACPTEIEN
SET ACPTEIEN=$ORDER(^ICPT(ACPTIEN,60,"B",+ACPTEDT,0))
+25 ;
+26 ; if there is one for this install date
IF ACPTEDT=3090901
IF ACPTEIEN
Begin DoDot:2
+27 ; if active, we're fine
IF $PIECE($GET(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2)
QUIT
+28 ; otherwise, we need to activate it:
+29 KILL DIC,DIE,DA,DIR,X,Y
+30 ; IEN of last Effective Date
SET DA=+ACPTEIEN
+31 ; IEN of its parent CPT
SET DA(1)=ACPTIEN
+32 ; Effective Date (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+33 ; set Status field to ACTIVE
SET DR=".02////1"
+34 ; other parameters for DIE
NEW DIDEL,DTOUT
+35 ; Fileman Data Edit call
DO ^DIE
End DoDot:2
+36 ;
+37 ; if not, then we need one
IF '$TEST
Begin DoDot:2
+38 KILL DIC,DIE,DA,X,Y,DIR
+39 ; into subfile under new entry
SET DA(1)=ACPTIEN
+40 ; Effective Date (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+41 ; LAYGO
SET DIC(0)="L"
+42 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),U,2)
+43 ; new entry for 9/1/2009
SET X="09/01/2009"
+44 IF ACPTCODE="Q2023"
SET X="07/01/2009"
+45 ; with Status = 1 (active)
SET DIC("DR")=".02////1"
+46 ; other parameters
NEW DLAYGO,Y,DTOUT,DUOUT
+47 ; Fileman LAYGO lookup
DO ^DIC
End DoDot:2
End DoDot:1
+48 QUIT
TEXT(ACPTDESC) ; convert Description text to Word-Processing data type
+1 ; input: .ACPTDESC = passed by reference, starts out as long string,
+2 ; ends as Fileman WP-format array complete with header
+3 ;
+4 ; copy string out
NEW ACPTSTRN
SET ACPTSTRN=ACPTDESC
+5 ; clear what will now become a WP array
KILL ACPTDESC
+6 ; count WP lines for header
NEW ACPTCNT
SET ACPTCNT=0
+7 ;
+8 ; loop until ACPTSTRN is fully transformed
FOR
IF ACPTSTRN=""
QUIT
Begin DoDot:1
+9 ;
+10 ; character position to break at
NEW ACPTBRK
SET ACPTBRK=0
+11 ;
+12 ; find the character position to break at
Begin DoDot:2
+13 ; break position to try
NEW ACPTRY
+14 ; how long is the string?
SET ACPTRY=$LENGTH(ACPTSTRN)
+15 ; if 1 full line or less, we're done
IF ACPTRY<81
SET ACPTBRK=ACPTRY
QUIT
+16 ;
+17 FOR ACPTRY=80:-1:2
Begin DoDot:3
+18 ; can break on a space
IF $EXTRACT(ACPTSTRN,ACPTRY+1)=" "
Begin DoDot:4
+19 ; remove the space
SET $EXTRACT(ACPTSTRN,ACPTRY+1)=""
+20 ; and let's break here
SET ACPTBRK=ACPTRY
End DoDot:4
QUIT
+21 ;
+22 ; on delimiter?
IF "&_+-*/<=>}])|:;,.?!"[$EXTRACT(ACPTSTRN,ACPTRY)
Begin DoDot:4
+23 ; so let's break here
SET ACPTBRK=ACPTRY
End DoDot:4
QUIT
End DoDot:3
IF ACPTBRK
QUIT
+24 ;
+25 ; if we found a good spot to break, we're done
IF ACPTBRK
QUIT
+26 ;
+27 ; otherwise, hard-break on 80 (weird content)
SET ACPTBRK=80
End DoDot:2
+28 ;
+29 ; one more line
SET ACPTCNT=ACPTCNT+1
+30 ; copy line into array
SET ACPTDESC(ACPTCNT,0)=$EXTRACT(ACPTSTRN,1,ACPTBRK)
+31 ; & remove it from the string
SET $EXTRACT(ACPTSTRN,1,ACPTBRK)=""
End DoDot:1
+32 ;
+33 ; set WP header
SET ACPTDESC(0)="^81.01A^"_ACPTCNT_U_ACPTCNT_U_DT
+34 ;
+35 QUIT
DATA ;
+1 ;;G9141^INFLUENZA A IMM ORDER/ADMIN^Influenza A (H1N1) immunization administration (includes the physician counseling the patient/family)
+2 ;;G9142^INFLUENZA A VACC^Influenza A (H1N1) vaccine, any route of administration
+3 ;;Q2023^Xyntha, inj^INJECTION, FACTOR VIII (ANTIHEMOPHILIC FACTOR, RECOMBINANT) (XYNTHA), PER I.U.
+4 ;;END
