Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSDFIL2

PSDFIL2.m

Go to the documentation of this file.
  1. PSDFIL2 ;BIR/JPW,BJW-File TRAKKER Info - Vault Inv Adj ; 04 FEB 99
  1. ;;3.0; CONTROLLED SUBSTANCES ;**8,3,19,66**;13 Feb 97;Build 3
  1. ;nois#:cla-0199-20993; no reference to DBIAS's needed
  1. ;**Y2K compliance**after FM patch DI*21*44 installed
  1. EN1 ;entry for filing vault inventory adjustments trakker info
  1. K CNT,DA,DATA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSDS,PSDSN,X,X1,Y
  1. LOOP ;loop thru ^tmp
  1. K CNT S CNT=1
  1. W !!,"Updating DHCP now..."
  1. F PSD=0:0 S PSD=$O(^TMP("PSDWN2",$J,PSD)) Q:'PSD S NODE=^TMP("PSDWN2",$J,PSD,0) D
  1. .;DAVE B (PSD*3*19 12MAY99) Added length check
  1. .I NODE'["*",$L(NODE,"^")=2 S PHARM=$P(NODE,"^") S:$E(PHARM)="P" PHARM=$P(PHARM,"P",2) S PHARM=$P(PHARM,"-")_$P(PHARM,"-",2)_$P(PHARM,"-",3) D Q
  1. ..S PHARM=$S(PHARM]"":+$O(^VA(200,"SSN",PHARM,0)),1:"")
  1. ..S PSDTS=$P(NODE,">",2),X=$E(PSDTS,1,2) D ^%DT S PSDTS=$E(Y,1,3)_$E(PSDTS,4,5)_$E(PSDTS,7,8)_"."_$E(PSDTS,10,11)_$E(PSDTS,13,14)_$E(PSDTS,16,17),PSDTS=+PSDTS
  1. .I $L(NODE)<32,NODE["*" S PSDS=+$P(NODE,"*",2),PSDSN=$S($P($G(^PSD(58.8,PSDS,0)),"^")]"":$P($G(^(0)),"^"),1:"UNKNOWN") Q
  1. .S PHARM1=$P(NODE,"^"),PSDRN=$P(NODE,"^",3),OQTY=+$P(NODE,"^",4),QTY=+$P(NODE,"^",6),PHARM2=$P(NODE,"^",7)
  1. .S CQTY=+$P(NODE,"^",8),PSDTA=$P(NODE,"^",12)
  1. .S:$E(PHARM1)="P" PHARM1=$P(PHARM1,"P",2) S PHARM1=$P(PHARM1,"-")_$P(PHARM1,"-",2)_$P(PHARM1,"-",3),PHARM1=$S(PHARM1]"":+$O(^VA(200,"SSN",PHARM1,0)),1:"")
  1. .I PHARM2]"" S:$E(PHARM2)="P" PHARM2=$P(PHARM2,"P",2) S PHARM2=$P(PHARM2,"-")_$P(PHARM2,"-",2)_$P(PHARM2,"-",3),PHARM2=$S(PHARM2]"":+$O(^VA(200,"SSN",PHARM2,0)),1:"")
  1. .S PSDR=+$P(NODE,"^",2)
  1. .S X=$E(PSDTA,2,3) D ^%DT S PSDTA=$E(Y,1,3)_$E(PSDTA,5,6)_$E(PSDTA,8,9)_"."_$E(PSDTA,11,12)_$E(PSDTA,14,15)_$E(PSDTA,17,18),PSDTA=+PSDTA
  1. .S PSDTYP=$S('CQTY:20,1:9)
  1. .;I PSDTYP=9,CQTY=OQTY Q
  1. .I '$D(^TMP("PSDOK2",$J,19,+PSDR)) S ^TMP("PSDOK2",$J,19,+PSDR,+PSDTS,1)=19_"^"_PHARM_"^^^"
  1. .S ^TMP("PSDOK2",$J,+PSDTYP,+PSDR,+PSDTA,CNT)=PSDTYP_"^"_PHARM1_"^"_PHARM2_"^"_OQTY_"^"_CQTY
  1. .S CNT=CNT+1
  1. FIL ;file data
  1. S PSD="" F PSD=19,9,20 D
  1. .S PSDR="" F S PSDR=$O(^TMP("PSDOK2",$J,PSD,PSDR)) Q:PSDR="" S PSDTA="" F S PSDTA=$O(^TMP("PSDOK2",$J,PSD,PSDR,PSDTA)) Q:PSDTA="" S CNT="" F S CNT=$O(^TMP("PSDOK2",$J,PSD,PSDR,PSDTA,CNT)) Q:CNT="" D
  1. ..S NODE=^TMP("PSDOK2",$J,PSD,+PSDR,+PSDTA,CNT),PSDTYP=+$P(NODE,"^"),PHARM1=$P(NODE,"^",2),PHARM2=$P(NODE,"^",3),OQTY=$P(NODE,"^",4),CQTY=$P(NODE,"^",5),QTY=$S(PSDTYP=9:CQTY-OQTY,1:0)
  1. ..S PHARMN1=$S($P($G(^VA(200,+PHARM1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. ..D UPDATE
  1. W "done.",!
  1. END ;kill variables
  1. K %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,NAOU,NODE,OK,OQTY
  1. K PHARM,PHARM1,PHARM2,PHARMN1,PAT,PSD,PSDER,PSDR,PSDREC,PSDRN,PSDS,PSDSN,PSDT,PSDTA,PSDTS,PSDTYP,QTY,X,Y
  1. K ^TMP("PSDWN2",$J)
  1. K ^TMP("PSDOK2",$J)
  1. Q
  1. UPDATE ;update 58.8 and 58.81
  1. ;vault balance
  1. F L +^PSD(58.8,+PSDS,1,+PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. D NOW^%DTC S PSDT=+%
  1. S BAL=$P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+QTY
  1. L -^PSD(58.8,+PSDS,1,+PSDR,0)
  1. F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. FIND S PSDREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDREC)) S $P(^PSD(58.81,0),"^",3)=PSDREC G FIND
  1. K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO
  1. L -^PSD(58.81,0)
  1. EDIT ;edit new transaction in 58.81
  1. S ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP_"^"_+PSDS_"^"_$S(PSDTYP=19:PSDTS,1:PSDT)_"^"_PSDR_"^"_QTY_"^"_$S(PSDTYP=9:PHARM1,1:PHARM)_"^^^"_BAL_"^^^^^^"_$S(PSDTYP=9:"TRAKKER ADJUSTMENT",1:"TRAKKER INVENTORY")
  1. S:PSDTYP=9 ^PSD(58.81,PSDREC,9)="^^"_$S(PSDTYP=19:BAL,1:OQTY)_"^^^^"_CQTY_"^"_PHARM1_"^"_PHARM2_"^"_PSDTA
  1. S ^PSD(58.81,PSDREC,"CS")=1
  1. K DA,DIK S DA=PSDREC,DIK="^PSD(58.81," D IX^DIK K DA,DIK
  1. ;update vault
  1. I '$D(^PSD(58.8,+PSDS,1,+PSDR,4,0)) S ^(0)="^58.800119PA^^"
  1. I '$D(^PSD(58.8,+PSDS,1,+PSDR,4,+PSDREC,0)) K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+PSDS_",1,"_+PSDR_",4,",DA(2)=+PSDS,DA(1)=+PSDR,(X,DINUM)=PSDREC D FILE^DICN K DA,DIC,DD,D0
  1. I PSDTYP'=9 W "." Q
  1. ERR ;err log update
  1. F L +^PSD(58.89,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. FIND9 S PSDER=$P(^PSD(58.89,0),"^",3)+1 I $D(^PSD(58.89,PSDER)) S $P(^PSD(58.89,0),"^",3)=PSDER G FIND9
  1. K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.89,(X,DINUM)=PSDER D ^DIC K DIC,DLAYGO
  1. L -^PSD(58.89,0)
  1. EDIT9 ;edit error log
  1. K DA,DIE,DR S DA=PSDER,DIE=58.89,DR="1////"_PSDREC_";2////"_PSDT_";6////"_+PSDS D ^DIE K DA,DIE,DR
  1. D ^PSDFILM
  1. W "."
  1. Q