ACHSTX99 ; IHS/ITSC/PMF - copy export records for examination [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
Q
;
S DOLH=$G(DOLH) I DOLH="" S DOLH=$TR($H,",","_")
S PMFCOUNT=$G(PMFCOUNT)+1
;
I $G(ACHSDOCR)="" Q
I $G(PMFF)="" S PMFF=$G(^ACHSDATA(ACHSRCT))
;
I PMFF="" Q
;
;
S PMFDIEN=$G(ACHSDIEN)
;
I PMFDIEN="" S PMFDIEN=$G(P)
I PMFDIEN="" S PMFDIEN=$G(R)
;
;for test
;I PMFDIEN="" W !,"no dien" R G Q
;
;
S ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH)=ACHSDOCR
S ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH,PMFF)=""
;
S SDA=$G(SDA) I SDA="" S SDA="??"
S ^ACHSF(DUZ(2),"XPRT8",PMFDIEN,SDA,DOLH,PMFCOUNT)=PMFF
;
S PPMF=$E(PMFF)
S ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH)=$G(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH))+1
S ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF)=$G(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF))+1
;
;
K PMFF,PPMF,PMFDIEN
;
Q
;
CLEAN ;
N A,B,C,FAC,KILLH
S KILLH=$H-7
S FAC=0 F S FAC=$O(^ACHSF(FAC)) Q:FAC=""!'FAC D
. S A="XPR" F S A=$O(^ACHSF(FAC,A)) Q:A="" Q:$E(A,1,3)'="XPR" D
.. S B="" F S B=$O(^ACHSF(FAC,A,B)) Q:B="" D
... I A="XPRT",+B<KILLH K ^ACHSF(FAC,A,B) Q
... I A="XPRT" Q
... S C="" F S C=$O(^ACHSF(FAC,A,B,C)) Q:C="" D
.... I +C<KILLH K ^ACHSF(FAC,A,B,C)
.... Q
... Q
.. Q
. Q
Q
ACHSTX99 ; IHS/ITSC/PMF - copy export records for examination [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 QUIT
+4 ;
+5 SET DOLH=$GET(DOLH)
IF DOLH=""
SET DOLH=$TRANSLATE($HOROLOG,",","_")
+6 SET PMFCOUNT=$GET(PMFCOUNT)+1
+7 ;
+8 IF $GET(ACHSDOCR)=""
QUIT
+9 IF $GET(PMFF)=""
SET PMFF=$GET(^ACHSDATA(ACHSRCT))
+10 ;
+11 IF PMFF=""
QUIT
+12 ;
+13 ;
+14 SET PMFDIEN=$GET(ACHSDIEN)
+15 ;
+16 IF PMFDIEN=""
SET PMFDIEN=$GET(P)
+17 IF PMFDIEN=""
SET PMFDIEN=$GET(R)
+18 ;
+19 ;for test
+20 ;I PMFDIEN="" W !,"no dien" R G Q
+21 ;
+22 ;
+23 SET ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH)=ACHSDOCR
+24 SET ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH,PMFF)=""
+25 ;
+26 SET SDA=$GET(SDA)
IF SDA=""
SET SDA="??"
+27 SET ^ACHSF(DUZ(2),"XPRT8",PMFDIEN,SDA,DOLH,PMFCOUNT)=PMFF
+28 ;
+29 SET PPMF=$EXTRACT(PMFF)
+30 SET ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH)=$GET(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH))+1
+31 SET ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF)=$GET(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF))+1
+32 ;
+33 ;
+34 KILL PMFF,PPMF,PMFDIEN
+35 ;
+36 QUIT
+37 ;
CLEAN ;
+1 NEW A,B,C,FAC,KILLH
+2 SET KILLH=$HOROLOG-7
+3 SET FAC=0
FOR
SET FAC=$ORDER(^ACHSF(FAC))
IF FAC=""!'FAC
QUIT
Begin DoDot:1
+4 SET A="XPR"
FOR
SET A=$ORDER(^ACHSF(FAC,A))
IF A=""
QUIT
IF $EXTRACT(A,1,3)'="XPR"
QUIT
Begin DoDot:2
+5 SET B=""
FOR
SET B=$ORDER(^ACHSF(FAC,A,B))
IF B=""
QUIT
Begin DoDot:3
+6 IF A="XPRT"
IF +B<KILLH
KILL ^ACHSF(FAC,A,B)
QUIT
+7 IF A="XPRT"
QUIT
+8 SET C=""
FOR
SET C=$ORDER(^ACHSF(FAC,A,B,C))
IF C=""
QUIT
Begin DoDot:4
+9 IF +C<KILLH
KILL ^ACHSF(FAC,A,B,C)
+10 QUIT
End DoDot:4
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
